diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,4 @@ +# Revision History for inferno-lsp + +## 0.1.0.0 -- 2022-11-28 +* Prepare for OSS release diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,21 @@ +MIT License + +Copyright (c) 2022 Plow Technologies + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TypeApplications #-} + +module Main where + +-- import Inferno.LSP.Server (runInfernoLspServer) +-- import System.Exit (ExitCode (ExitFailure), exitSuccess, exitWith) + +main :: IO () +main = putStrLn "NOTE: the commented code in this file demonstrates how to instantiate Inferno with custom value types and obtain an executable." + +-- main = do +-- runInfernoLspServer @ValueType preludeNameToTypeMap >>= \case +-- 0 -> exitSuccess +-- c -> exitWith . ExitFailure $ c diff --git a/inferno-lsp.cabal b/inferno-lsp.cabal new file mode 100644 --- /dev/null +++ b/inferno-lsp.cabal @@ -0,0 +1,73 @@ +cabal-version: >=1.10 +name: inferno-lsp +version: 0.1.0 +synopsis: LSP for Inferno +description: A language server protocol implementation for the Inferno language +category: IDE,DSL,Scripting +homepage: https://github.com/plow-technologies/inferno.git#readme +bug-reports: https://github.com/plow-technologies/inferno.git/issues +copyright: Plow-Technologies LLC +license: MIT +license-file: LICENSE +author: Sam Balco +maintainer: info@plowtech.net +build-type: Simple +extra-source-files: CHANGELOG.md + +source-repository head + type: git + location: https://github.com/plow-technologies/inferno.git + +library + exposed-modules: + Inferno.LSP.Server + other-modules: + Inferno.LSP.Completion + , Inferno.LSP.ParseInfer + hs-source-dirs: + src + ghc-options: -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates + build-depends: + base >= 4.13 && < 4.17 + , bytestring >= 0.10.10 && < 0.12 + , co-log-core >= 0.3.1 && < 0.4 + , containers >= 0.6.2 && < 0.7 + , inferno-core >= 0.1.0 && < 0.2 + , inferno-types >= 0.1.0 && < 0.2 + , inferno-vc >= 0.1.0 && < 0.2 + , lsp >= 1.6.0 && < 1.7 + , lsp-types >= 1.6.0 && < 1.7 + , megaparsec >= 9.2.1 && < 9.3 + , microlens >= 0.4.13 && < 0.5 + , mtl >= 2.2.2 && < 2.3 + , plow-log >= 0.1.6 && < 0.2 + , plow-log-async >= 0.1.4 && < 0.2 + , prettyprinter >= 1.7.1 && < 1.8 + , safe >= 0.3.19 && < 0.4 + , special-keys >= 0.1.0 && < 0.2 + , stm >= 2.5.0 && < 2.6 + , text >= 2.0.1 && < 2.1 + , text-rope >= 0.2 && < 0.3 + , time >= 1.9.3 && < 1.12 + , transformers >= 0.5.6 && < 0.6 + , uuid >= 1.3.15 && < 1.4 + default-language: Haskell2010 + default-extensions: + DeriveDataTypeable + , DeriveFunctor + , DeriveGeneric + , FlexibleContexts + , FlexibleInstances + , LambdaCase + , MultiParamTypeClasses + , OverloadedStrings + , TupleSections + +executable inferno-lsp-server + main-is: Main.hs + hs-source-dirs: + app + ghc-options: -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -threaded -rtsopts -with-rtsopts=-T + build-depends: + base >=4.7 && <5 + default-language: Haskell2010 diff --git a/src/Inferno/LSP/Completion.hs b/src/Inferno/LSP/Completion.hs new file mode 100644 --- /dev/null +++ b/src/Inferno/LSP/Completion.hs @@ -0,0 +1,228 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +module Inferno.LSP.Completion where + +import Control.Monad.Except (MonadError) +import Data.List (delete, nub) +import qualified Data.List.NonEmpty as NonEmpty +import qualified Data.Map as Map +import qualified Data.Maybe as Maybe +import Data.Text (Text) +import qualified Data.Text as Text +import Inferno.Eval.Error (EvalError) +import Inferno.LSP.ParseInfer (getTypeMetadataText, mkPrettyTy) +import Inferno.Module.Prelude (ModuleMap) +import Inferno.Types.Syntax (Ident (..), ModuleName (..), rws) +import Inferno.Types.Type (Namespace (..), TCScheme, TypeMetadata (..)) +import Inferno.Utils.Prettyprinter (renderDoc, renderPretty) +import Language.LSP.Types + ( CompletionDoc (..), + CompletionItem (..), + CompletionItemKind (..), + MarkupContent (MarkupContent), + MarkupKind (..), + Position (..), + ) +import Prettyprinter (Pretty) + +-- | Given the cursor position construct the corresponding 'completion query' +-- consisting of the leadup, i.e. text leading up to the word prefix that is to +-- be completed, as well as the prefix that is to be completed. +completionQueryAt :: Text -> Position -> (Text, Text) +completionQueryAt text pos = (completionLeadup, completionPrefix) + where + off = positionToOffset text pos + text' = Text.take off text + breakEnd :: (Char -> Bool) -> Text -> (Text, Text) + breakEnd p = + (\(l, r) -> (Text.reverse l, Text.reverse r)) . Text.break p . Text.reverse + (completionPrefix, completionLeadup) = + breakEnd (`elem` (" \t\n[(,=+*&|}?>" :: String)) text' + + positionToOffset :: Text -> Position -> Int + positionToOffset txt (Position line col) = + if fromIntegral line < length ls + then Text.length . unlines' $ take (fromIntegral line) ls ++ [Text.take (fromIntegral col) (ls !! fromIntegral line)] + else Text.length txt -- position lies outside txt + where + ls = NonEmpty.toList (lines' txt) + + lines' :: Text -> NonEmpty.NonEmpty Text + lines' t = + case Text.split (== '\n') t of + [] -> "" NonEmpty.:| [] -- this case never occurs! + l : ls -> l NonEmpty.:| ls + unlines' :: [Text] -> Text + unlines' = Text.intercalate "\n" + +findInPrelude :: forall c. (Pretty c, Eq c) => Map.Map (Maybe ModuleName, Namespace) (TypeMetadata TCScheme) -> Text -> [((Maybe ModuleName, Namespace), TypeMetadata TCScheme)] +findInPrelude preludeNameToTypeMap prefix = + let prefixIsEnum = "#" `Text.isPrefixOf` prefix + -- 'preludeNameToTypeMap' stores the enum's ident without '#'. + -- When comparing the prefix, we have to drop the '#'. + lcPrefix' = (if prefixIsEnum then Text.drop 1 else id) $ Text.toLower prefix + lcPrefix = (if "." `Text.isSuffixOf` lcPrefix' then Text.dropEnd 1 else id) lcPrefix' + in Map.toList $ + Map.filterWithKey + ( \(mModule, ns) _ -> + case mModule of + _ | prefixIsEnum -> filterEnum ns lcPrefix + Just m -> + lcPrefix + `Text.isPrefixOf` Text.toLower (Text.toLower $ unModuleName m) + || filterNs ns lcPrefix + || filterNsWithModuleName m ns lcPrefix + -- In the case of enum, we should only show enums + Nothing -> filterNs ns lcPrefix + ) + preludeNameToTypeMap + where + filterEnum ns lcPrefix = case ns of + EnumNamespace (Ident i) -> lcPrefix `Text.isPrefixOf` Text.toLower i + _ -> False + + filterNs ns lcPrefix = case ns of + FunNamespace (Ident i) -> lcPrefix `Text.isPrefixOf` Text.toLower i + OpNamespace (Ident i) -> lcPrefix `Text.isPrefixOf` Text.toLower i + EnumNamespace (Ident i) -> lcPrefix `Text.isPrefixOf` Text.toLower i + ModuleNamespace (ModuleName n) -> lcPrefix `Text.isPrefixOf` Text.toLower n + TypeNamespace _ -> False + + filterNsWithModuleName (ModuleName mn) ns lcPrefix = do + let mn' = Text.append (Text.toLower mn) "." + case ns of + FunNamespace (Ident i) -> lcPrefix `Text.isPrefixOf` Text.append mn' (Text.toLower i) + OpNamespace (Ident i) -> lcPrefix `Text.isPrefixOf` Text.append mn' (Text.toLower i) + EnumNamespace (Ident i) -> lcPrefix `Text.isPrefixOf` Text.append mn' (Text.toLower i) + ModuleNamespace (ModuleName n) -> lcPrefix `Text.isPrefixOf` Text.append mn' (Text.toLower n) + TypeNamespace _ -> False + +mkCompletionItem :: forall m c. (MonadError EvalError m, Pretty c, Eq c) => ModuleMap m c -> Text -> (Maybe ModuleName, Namespace) -> TypeMetadata TCScheme -> CompletionItem +mkCompletionItem prelude txt (modNm, ns) tm@TypeMetadata {ty} = + CompletionItem + { _label = insertModNm $ renderPretty ns, + _kind = case ns of + FunNamespace _ -> Just CiFunction + OpNamespace _ -> Just CiFunction + EnumNamespace _ -> Just CiEnum + ModuleNamespace _ -> Just CiModule + TypeNamespace _ -> Nothing, + _tags = Nothing, + _detail = Just $ renderDoc $ mkPrettyTy prelude mempty ty, + _documentation = CompletionDocMarkup . MarkupContent MkMarkdown <$> getTypeMetadataText tm, + _deprecated = Nothing, + _preselect = Nothing, + _sortText = Nothing, + _filterText = + let ftxt = insertModNm $ renderPretty ns + ftxt' = (if "#" `Text.isPrefixOf` ftxt then Text.drop 1 else id) ftxt + in Just ftxt', + _insertText = case ns of + EnumNamespace (Ident i) -> if "#" `Text.isPrefixOf` txt then Just i else Nothing + _ -> Nothing, + _insertTextMode = Nothing, + _insertTextFormat = Nothing, + _textEdit = Nothing, + _additionalTextEdits = Nothing, + _commitCharacters = Nothing, + _command = Nothing, + _xdata = Nothing + } + where + insertModNm txt' = case modNm of + Nothing -> txt' + Just (ModuleName n) -> do + let moduleName = n <> "." + if moduleName `Text.isPrefixOf` txt + then txt' + else moduleName <> txt' + +-- | Create completion for user provided identifier e.g. input0, etc +identifierCompletionItems :: [Text] -> Text -> [CompletionItem] +identifierCompletionItems idents prefix + | "." `Text.isSuffixOf` prefix = [] -- For case like "Module.", returned empty because identifier has no namespace/module prefix + | otherwise = fmap makeIdentifierCompletion $ filter (\identifier -> prefix `Text.isPrefixOf` identifier) idents + where + makeIdentifierCompletion identifier = + CompletionItem + { _label = identifier, + _kind = Just CiVariable, + _tags = Nothing, + _detail = Nothing, + _documentation = Nothing, + _deprecated = Nothing, + _preselect = Nothing, + _sortText = Nothing, + _filterText = Just identifier, + _insertText = Nothing, + _insertTextMode = Nothing, + _insertTextFormat = Nothing, + _textEdit = Nothing, + _additionalTextEdits = Nothing, + _commitCharacters = Nothing, + _command = Nothing, + _xdata = Nothing + } + +rwsCompletionItems :: Text -> [CompletionItem] +rwsCompletionItems prefix + | "." `Text.isSuffixOf` prefix = [] -- For case like "Module.", returned empty because identifier has no namespace/module prefix + | otherwise = map mkRwsCompletionItem $ filter (\rw -> prefix `Text.isPrefixOf` rw) filteredRws + where + -- `None` and `Some` are already included elsewhere + filteredRws :: [Text] + filteredRws = delete "Some" $ delete "None" rws + + -- Create a CompletionItem for each reserved word + mkRwsCompletionItem :: Text -> CompletionItem + mkRwsCompletionItem rw = + CompletionItem + { _label = rw, + _kind = Just CiKeyword, + _tags = Nothing, + _detail = Nothing, + _documentation = Nothing, + _deprecated = Nothing, + _preselect = Nothing, + _sortText = Nothing, + _filterText = Nothing, + _insertText = Nothing, + _insertTextMode = Nothing, + _insertTextFormat = Nothing, + _textEdit = Nothing, + _additionalTextEdits = Nothing, + _commitCharacters = Nothing, + _command = Nothing, + _xdata = Nothing + } + +moduleNameCompletionItems :: forall c. (Pretty c, Eq c) => Map.Map (Maybe ModuleName, Namespace) (TypeMetadata TCScheme) -> [CompletionItem] +moduleNameCompletionItems preludeNameToTypeMap = fmap mkModuleCompletionItem modules + where + modules = nub . fmap unModuleName . Maybe.catMaybes . fmap fst $ Map.keys preludeNameToTypeMap + mkModuleCompletionItem m = + CompletionItem + { _label = m, + _kind = Just CiModule, + _tags = Nothing, + _detail = Nothing, + _documentation = Nothing, + _deprecated = Nothing, + _preselect = Nothing, + _sortText = Nothing, + _filterText = Just m, + _insertText = Just m, + _insertTextMode = Nothing, + _insertTextFormat = Nothing, + _textEdit = Nothing, + _additionalTextEdits = Nothing, + _commitCharacters = Nothing, + _command = Nothing, + _xdata = Nothing + } + +filterModuleNameCompletionItems :: forall c. (Pretty c, Eq c) => Map.Map (Maybe ModuleName, Namespace) (TypeMetadata TCScheme) -> Text -> [CompletionItem] +filterModuleNameCompletionItems preludeNameToTypeMap prefix = filter (\item -> prefix `Text.isPrefixOf` _label item) (moduleNameCompletionItems @c preludeNameToTypeMap) diff --git a/src/Inferno/LSP/ParseInfer.hs b/src/Inferno/LSP/ParseInfer.hs new file mode 100644 --- /dev/null +++ b/src/Inferno/LSP/ParseInfer.hs @@ -0,0 +1,696 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +module Inferno.LSP.ParseInfer where + +import Control.Monad (forM_) +import Control.Monad.Except (MonadError) +import Control.Monad.IO.Class (MonadIO (..)) +import Data.Either (isLeft) +import Data.List (find, findIndices, nub, sort) +import qualified Data.List.NonEmpty as NEList +import qualified Data.Map as Map +import Data.Maybe (catMaybes, fromMaybe, listToMaybe, mapMaybe) +import qualified Data.Set as Set +import Data.Text (Text, pack) +import qualified Data.Text as Text +import Inferno.Eval.Error (EvalError) +import Inferno.Infer (TypeError (..), closeOverType, findTypeClassWitnesses, inferExpr, inferPossibleTypes, inferTypeReps) +import Inferno.Infer.Env (Namespace (..)) +import Inferno.Infer.Pinned (pinExpr) +import Inferno.Module (Module (..)) +import Inferno.Module.Builtin (builtinModule) +import Inferno.Module.Prelude (ModuleMap, baseOpsTable, builtinModulesOpsTable, builtinModulesPinMap) +import Inferno.Parse (InfernoParsingError, parseExpr, parseType) +import Inferno.Parse.Commented (insertCommentsIntoExpr) +import Inferno.Parse.Error (prettyError) +import Inferno.Types.Syntax (Comment, Expr (..), ExtIdent (..), Ident (..), ModuleName (..), Scoped (..), getIdentifierPositions, hideInternalIdents) +import Inferno.Types.Type + ( BaseType (..), + ImplType (ImplType), + InfernoType (..), + TCScheme (..), + TypeClass (..), + TypeClassShape (..), + TypeMetadata (..), + apply, + ftv, + punctuate', + ) +import Inferno.Types.VersionControl (Pinned (..), VCObjectHash) +import Inferno.Utils.Prettyprinter (renderDoc, renderPretty) +import Language.LSP.Types + ( Diagnostic (..), + DiagnosticSeverity (DsError), + MarkupContent (..), + MarkupKind (MkMarkdown), + Range, + mkRange, + ) +import Prettyprinter + ( Doc, + Pretty (pretty), + align, + hardline, + indent, + sep, + vsep, + (<+>), + ) +import qualified Safe +import Text.Megaparsec.Error (ParseError, ShowErrorComponent) +import Text.Megaparsec.Pos (SourcePos (..), unPos) + +parseExprInBaseModule :: + forall m c. + (MonadError EvalError m, Pretty c, Eq c) => + ModuleMap m c -> + Text -> + Either + (NEList.NonEmpty (ParseError Text InfernoParsingError, SourcePos)) + (Expr () SourcePos, [Comment SourcePos]) +parseExprInBaseModule prelude = + parseExpr (baseOpsTable prelude) (builtinModulesOpsTable prelude) + +errorDiagnostic :: Int -> Int -> Int -> Int -> Maybe Text -> Text -> Diagnostic +errorDiagnostic s_line s_col e_line e_col source message = + Diagnostic + { _range = mkRange (fromIntegral s_line - 2) (fromIntegral s_col - 1) (fromIntegral e_line - 2) (fromIntegral e_col - 1), + _severity = Just DsError, + _code = Nothing, + _source = source, + _message = message, + _tags = Nothing, + _relatedInformation = Nothing + } + +parseErrorDiagnostic :: ShowErrorComponent e => (ParseError Text e, SourcePos) -> Diagnostic +parseErrorDiagnostic (err, SourcePos _ l c) = + errorDiagnostic + 0 + 0 + (unPos l - 1) + (unPos c) + (Just "inferno.parser") + (pack $ prettyError err) + +errorDiagnosticInfer :: Int -> Int -> Int -> Int -> Text -> Diagnostic +errorDiagnosticInfer s_line s_col e_line e_col = errorDiagnostic s_line s_col e_line e_col (Just "inferno.infer") + +inferErrorDiagnostic :: TypeError SourcePos -> [Diagnostic] +inferErrorDiagnostic = \case + UnificationFail _ t1 t2 (s, e) -> + [ errorDiagnosticInfer + (unPos $ sourceLine s) + (unPos $ sourceColumn s) + (unPos $ sourceLine e) + (unPos $ sourceColumn e) + $ renderDoc + $ vsep + [ "Could not match the type", + indent 2 (pretty $ closeOverType t1), + "with", + indent 2 (pretty $ closeOverType t2) + ] + ] + ExpectedFunction _ t1 t2 (s, e) -> + [ errorDiagnosticInfer + (unPos $ sourceLine s) + (unPos $ sourceColumn s) + (unPos $ sourceLine e) + (unPos $ sourceColumn e) + $ renderDoc + $ vsep + [ "Expected a function here of type", + indent 2 (pretty $ closeOverType t1), + "but instead found", + indent 2 (pretty $ closeOverType t2) + ] + ] + InfiniteType tv t (s, e) -> + [ errorDiagnosticInfer + (unPos $ sourceLine s) + (unPos $ sourceColumn s) + (unPos $ sourceLine e) + (unPos $ sourceColumn e) + $ renderDoc + $ "Could not unify" <+> pretty tv <+> "~" <+> (pretty $ closeOverType t) + ] + UnboundExtIdent modNm v (s, e) -> + [ errorDiagnosticInfer + (unPos $ sourceLine s) + (unPos $ sourceColumn s) + (unPos $ sourceLine e) + (unPos $ sourceColumn e) + $ renderDoc + $ "Unbound variable '" + <> ( case modNm of + LocalScope -> "" + Scope (ModuleName nm) -> pretty nm <> "." + ) + <> pretty v + <> "'" + ] + UnboundNameInNamespace modNm (Right n) (s, e) -> + [ errorDiagnosticInfer + (unPos $ sourceLine s) + (unPos $ sourceColumn s) + (unPos $ sourceLine e) + (unPos $ sourceColumn e) + $ case n of + FunNamespace (Ident v) -> + "Unbound variable '" + <> ( case modNm of + LocalScope -> "" + Scope (ModuleName nm) -> nm <> "." + ) + <> v + <> "'" + OpNamespace (Ident v) -> + "Unbound operator '" + <> ( case modNm of + LocalScope -> "" + Scope (ModuleName nm) -> nm <> "." + ) + <> v + <> "'" + ModuleNamespace (ModuleName v) -> + "Module '" + <> ( case modNm of + LocalScope -> "" + Scope (ModuleName nm) -> nm <> "." + ) + <> v + <> "' could not be found." + TypeNamespace (Ident v) -> + "Type '" + <> ( case modNm of + LocalScope -> "" + Scope (ModuleName nm) -> nm <> "." + ) + <> v + <> "' could not be found." + EnumNamespace (Ident c) -> + renderDoc $ + vsep + [ "Could not find the enum constructor '#" + <> ( case modNm of + LocalScope -> mempty + Scope (ModuleName nm) -> pretty nm <> "." + ) + <> pretty c + <> "'.", + "Make sure the enum you are trying to use has been imported" + ] + ] + UnboundNameInNamespace _modNm (Left h) (s, e) -> + [ errorDiagnosticInfer + (unPos $ sourceLine s) + (unPos $ sourceColumn s) + (unPos $ sourceLine e) + (unPos $ sourceColumn e) + $ "Object with has '" + <> Text.pack (show h) + <> "' could not be found." + ] + ImplicitVarTypeOverlap _ (ExtIdent ident) t1 t2 (s, e) -> + [ errorDiagnosticInfer + (unPos $ sourceLine s) + (unPos $ sourceColumn s) + (unPos $ sourceLine e) + (unPos $ sourceColumn e) + $ renderDoc + $ vsep + [ "The implicit variable '" <> case ident of { Left i -> "var$" <> pretty i; Right i -> pretty i } <> "' has multiple types:", + indent 2 (pretty $ closeOverType $ t1), + "and", + indent 2 (pretty $ closeOverType $ t2) + ] + ] + VarMultipleOccurrence (Ident x) (s2, e2) (s1, e1) -> + let message = + renderDoc $ + vsep + [ "Duplicate declarations of '" <> pretty x <> "' in the pattern match", + "at line" <+> pretty (unPos $ sourceLine s1) <> "," <+> "column" <+> pretty (unPos $ sourceColumn s1), + "and line" <+> pretty (unPos $ sourceLine s2) <> "," <+> "column" <+> pretty (unPos $ sourceColumn s2) + ] + in [ errorDiagnosticInfer + (unPos $ sourceLine s1) + (unPos $ sourceColumn s1) + (unPos $ sourceLine e1) + (unPos $ sourceColumn e1) + $ message, + errorDiagnosticInfer + (unPos $ sourceLine s2) + (unPos $ sourceColumn s2) + (unPos $ sourceLine e2) + (unPos $ sourceColumn e2) + $ message + ] + IfConditionMustBeBool _ t (s, e) -> + [ errorDiagnosticInfer + (unPos $ sourceLine s) + (unPos $ sourceColumn s) + (unPos $ sourceLine e) + (unPos $ sourceColumn e) + $ renderDoc + $ vsep + [ "The type of the if condition was expected to be a bool, instead I found", + indent 2 (pretty $ closeOverType t) + ] + ] + AssertConditionMustBeBool _ t (s, e) -> + [ errorDiagnosticInfer + (unPos $ sourceLine s) + (unPos $ sourceColumn s) + (unPos $ sourceLine e) + (unPos $ sourceColumn e) + $ renderDoc + $ vsep + [ "The type of the assert condition was expected to be a bool, instead I found", + indent 2 (pretty $ closeOverType t) + ] + ] + IfBranchesMustBeEqType _ t1 t2 (s1, e1) (s2, e2) -> + let message = + renderDoc $ + vsep + [ "The type of both branches of the if statement must be the same, however I found two different types:", + indent 2 (pretty $ closeOverType t1), + "and", + indent 2 (pretty $ closeOverType t2) + ] + in [ errorDiagnosticInfer + (unPos $ sourceLine s1) + (unPos $ sourceColumn s1) + (unPos $ sourceLine e1) + (unPos $ sourceColumn e1) + $ message, + errorDiagnosticInfer + (unPos $ sourceLine s2) + (unPos $ sourceColumn s2) + (unPos $ sourceLine e2) + (unPos $ sourceColumn e2) + $ message + ] + CaseBranchesMustBeEqType _ t1 t2 (s1, e1) (s2, e2) -> + let message = + renderDoc $ + vsep + [ "The type of all case branches must be the same, but I found two different types:", + indent 2 (pretty $ closeOverType t1), + "and", + indent 2 (pretty $ closeOverType t2) + ] + in [ errorDiagnosticInfer + (unPos $ sourceLine s1) + (unPos $ sourceColumn s1) + (unPos $ sourceLine e1) + (unPos $ sourceColumn e1) + $ message, + errorDiagnosticInfer + (unPos $ sourceLine s2) + (unPos $ sourceColumn s2) + (unPos $ sourceLine e2) + (unPos $ sourceColumn e2) + $ message + ] + PatternUnificationFail tPat tE p (s, e) -> + [ errorDiagnosticInfer + (unPos $ sourceLine s) + (unPos $ sourceColumn s) + (unPos $ sourceLine e) + (unPos $ sourceColumn e) + $ renderDoc + $ vsep + [ "The type of the pattern does not match the case expression", + "expected", + indent 2 (pretty $ closeOverType tE), + "but instead found", + indent 2 (pretty p <+> ":" <+> align (pretty $ closeOverType tPat)) + ] + ] + PatternsMustBeEqType _ t1 t2 p1 p2 (s1, e1) (s2, e2) -> + let message = + renderDoc $ + vsep + [ "The type of all case patterns must be the same, but I found two different types:", + indent 2 (pretty p1 <+> ":" <+> align (pretty $ closeOverType t1)), + "and", + indent 2 (pretty p2 <+> ":" <+> align (pretty $ closeOverType t2)) + ] + in [ errorDiagnosticInfer + (unPos $ sourceLine s1) + (unPos $ sourceColumn s1) + (unPos $ sourceLine e1) + (unPos $ sourceColumn e1) + $ message, + errorDiagnosticInfer + (unPos $ sourceLine s2) + (unPos $ sourceColumn s2) + (unPos $ sourceLine e2) + (unPos $ sourceColumn e2) + $ message + ] + NonExhaustivePatternMatch pat (s, e) -> + [ errorDiagnosticInfer + (unPos $ sourceLine s) + (unPos $ sourceColumn s) + (unPos $ sourceLine e) + (unPos $ sourceColumn e) + $ renderDoc + $ vsep + [ "The patterns in this case expression are non-exhaustive.", + "For example, the following pattern is missing:", + indent 2 (pretty $ pat) + ] + ] + UselessPattern (Just pat) (s, e) -> + [ errorDiagnosticInfer + (unPos $ sourceLine s) + (unPos $ sourceColumn s) + (unPos $ sourceLine e) + (unPos $ sourceColumn e) + $ renderDoc + $ vsep + [ "This case is unreachable, since it is subsumed by the previous pattern", + indent 2 (pretty $ pat) + ] + ] + UselessPattern Nothing (s, e) -> + [ errorDiagnosticInfer + (unPos $ sourceLine s) + (unPos $ sourceColumn s) + (unPos $ sourceLine e) + (unPos $ sourceColumn e) + $ renderDoc + $ "This case is unreachable, since it is subsumed by the previous patterns" + ] + -- TypeClassUnificationError t1 t2 tcs (s, e) -> + -- [ errorDiagnosticInfer + -- (unPos $ sourceLine s) + -- (unPos $ sourceColumn s) + -- (unPos $ sourceLine e) + -- (unPos $ sourceColumn e) + -- $ renderDoc $ + -- vsep + -- [ "Could not match the type", + -- indent 2 (pretty $ closeOverType t1), + -- "with", + -- indent 2 (pretty $ closeOverType t2), + -- "arising from this definition constraint:", + -- indent 2 (pretty $ tcs) + -- ] + -- ] + TypeClassNotFoundError _ tcls (s, e) -> + [ errorDiagnosticInfer + (unPos $ sourceLine s) + (unPos $ sourceColumn s) + (unPos $ sourceLine e) + (unPos $ sourceColumn e) + $ renderDoc + $ vsep + [ "Could not find any definitions for", + indent 2 (pretty $ TypeClassShape tcls) + ] + ] + TypeClassNoPartialMatch tcls (s, e) -> + [ errorDiagnosticInfer + (unPos $ sourceLine s) + (unPos $ sourceColumn s) + (unPos $ sourceLine e) + (unPos $ sourceColumn e) + $ renderDoc + $ vsep + [ "Could not find any matching definitions for", + indent 2 (pretty $ TypeClassShape tcls) + ] + ] + ModuleNameTaken (ModuleName m) (s, e) -> + [ errorDiagnosticInfer + (unPos $ sourceLine s) + (unPos $ sourceColumn s) + (unPos $ sourceLine e) + (unPos $ sourceColumn e) + $ renderDoc + $ vsep + [ "The chosen module name already exists:", + indent 2 (pretty m) + ] + ] + ModuleDoesNotExist (ModuleName m) (s, e) -> + [ errorDiagnosticInfer + (unPos $ sourceLine s) + (unPos $ sourceColumn s) + (unPos $ sourceLine e) + (unPos $ sourceColumn e) + $ renderDoc + $ vsep + [ "The following module does not exist:", + indent 2 (pretty m), + "make sure you have imported the module" + ] + ] + NameInModuleDoesNotExist (ModuleName m) (Ident i) (s, e) -> + [ errorDiagnosticInfer + (unPos $ sourceLine s) + (unPos $ sourceColumn s) + (unPos $ sourceLine e) + (unPos $ sourceColumn e) + $ renderDoc + $ vsep + [ "The module", + indent 2 (pretty m), + "does not contain:", + indent 2 (pretty i) + ] + ] + AmbiguousName (ModuleName m) i (s, e) -> + [ errorDiagnosticInfer + (unPos $ sourceLine s) + (unPos $ sourceColumn s) + (unPos $ sourceLine e) + (unPos $ sourceColumn e) + $ renderDoc + $ vsep + [ "The name", + indent 2 (pretty i), + "you are trying to import from", + indent 2 (pretty m), + "already exists in local scope and would be overshadowed. Consider using:", + indent 2 $ (pretty m) <> "." <> (pretty i) + ] + ] + CouldNotFindTypeclassWitness tyCls (s, e) -> + [ errorDiagnosticInfer + (unPos $ sourceLine s) + (unPos $ sourceColumn s) + (unPos $ sourceLine e) + (unPos $ sourceColumn e) + $ renderDoc + $ vsep + $ "Could not find any matching assignment of types which satisfies the type class constraints:" + : [ indent 2 (pretty c) | c <- Set.toList tyCls + ] + ] + +allClasses :: forall m c. (MonadError EvalError m, Pretty c, Eq c) => ModuleMap m c -> Set.Set TypeClass +allClasses prelude = Set.unions $ moduleTypeClasses builtinModule : [cls | Module {moduleTypeClasses = cls} <- Map.elems prelude] + +parseAndInfer :: forall m1 m2 c. (MonadError EvalError m1, Pretty c, Eq c, MonadIO m2) => ModuleMap m1 c -> [Maybe Ident] -> Text -> (InfernoType -> Either Text ()) -> m2 (Either [Diagnostic] (Expr (Pinned VCObjectHash) (), TCScheme, [(Range, MarkupContent)])) +parseAndInfer prelude idents txt validateInput = do + let input = case idents of + [] -> "\n" <> txt + ids -> "fun " <> (Text.intercalate " " $ map (maybe "_" (\(Ident i) -> i)) ids) <> " -> \n" <> txt + -- AppConfig _ _ tracer <- ask + -- let trace = const $ pure () --traceWith tracer + case (parseExprInBaseModule prelude) input of + Left err -> do + -- liftIO $ debugM "reactor.handle" $ "Parsing error: " ++ show err + return $ Left $ fmap parseErrorDiagnostic $ NEList.toList err + Right (ast, comments) -> do + -- liftIO $ debugM "reactor.handle" $ "Finished parsing" + case pinExpr (builtinModulesPinMap prelude) ast of + Left err -> do + -- liftIO $ debugM "reactor.handle" $ "Pinning error: " ++ show err + return $ Left $ concatMap inferErrorDiagnostic $ Set.toList $ Set.fromList err + Right pinnedAST -> do + -- liftIO $ debugM "reactor.handle" $ "Finished pinning" + case inferExpr prelude pinnedAST of + Left err -> do + -- liftIO $ debugM "reactor.handle" $ "Infer error: " ++ show err + return $ Left $ concatMap inferErrorDiagnostic $ Set.toList $ Set.fromList err + Right (pinnedAST', tcSch@(ForallTC _ currentClasses (ImplType _ typSig)), tyMap) -> do + liftIO $ print typSig + let possibleInputErrors = validateInputs typSig + case find isLeft possibleInputErrors of + Just (Left err) -> do + -- Get the idents that correspond to the indices + let indices = findIndices isLeft possibleInputErrors + let badIdent = listToMaybe $ catMaybes (mapMaybe (Safe.atMay idents) indices) + case badIdent of + Nothing -> return $ Left [errorDiagnosticInfer 0 0 0 0 $ renderPretty ["Could not find the input that caused the error. " `Text.append` err]] + Just ident@(Ident _i) -> do + let mIdentPos = listToMaybe $ getIdentifierPositions ident pinnedAST' + case mIdentPos of + Nothing -> return $ Left [errorDiagnosticInfer 0 0 0 2 $ renderDoc $ vsep ["Could not find the input that caused the error"]] + Just (s, e) -> return $ Left [errorDiagnosticInfer (unPos $ sourceLine s) (unPos $ sourceColumn s) (unPos $ sourceLine e) (unPos $ sourceColumn e) err] + _ -> do + -- liftIO $ debugM "reactor.handle" $ "Finished inferring" + let final = insertCommentsIntoExpr comments pinnedAST' + return $ + Right + ( fmap (const ()) final, + tcSch, + Map.foldrWithKey (\k v xs -> (mkHover prelude currentClasses k v) : xs) mempty tyMap + ) + where + -- Example: The type signature has the format for 3 inputs: + -- TArr + -- Input1 + -- TArr + -- Input2 + -- TArr + -- Input3 + -- Output + -- + -- Therefore we need to check the type of the first value in each TArr to see if it is a valid input type + -- The final output value will be ignored + validateInputs :: InfernoType -> [Either Text ()] + validateInputs = \case + -- Ignore validation if the final output is an array + typSig | isOutputAnArray typSig -> [Right ()] + -- Head is input, tail *could* be other inputs + TArr h t | isTArr t -> validateInput h : validateInputs t + -- Tail of this would be the output + TArr h _t | not (isTArr h) -> [validateInput h] + -- Top level is not an arr, assume it is correct to prevent errors + _ -> [Right ()] + + isTArr :: InfernoType -> Bool + isTArr = \case + TArr _ _ -> True + _ -> False + + isOutputAnArray :: InfernoType -> Bool + isOutputAnArray = \case + TArr _h t -> isOutputAnArray t + TArray _ -> True + _ -> False + +parseAndInferPretty :: forall m c. (MonadError EvalError m, Pretty c, Eq c) => ModuleMap m c -> Text -> IO () +parseAndInferPretty prelude txt = + (parseAndInfer @m @_ @c prelude) [] txt (const $ Right ()) >>= \case + Left err -> print err + Right (expr, typ, _hovers) -> do + putStrLn $ Text.unpack $ "internal: " <> renderPretty expr + + putStrLn $ Text.unpack $ "\nhidden: " <> renderPretty (hideInternalIdents expr) + + putStrLn $ Text.unpack $ "\ntype: " <> renderPretty typ + + putStrLn $ "\ntype (pretty)" <> (Text.unpack $ renderDoc $ mkPrettyTy prelude mempty typ) + +parseAndInferTypeReps :: forall m c. (MonadError EvalError m, Pretty c, Eq c) => ModuleMap m c -> Text -> [Text] -> Text -> IO () +parseAndInferTypeReps prelude expr inTys outTy = + (parseAndInfer @m @_ @c prelude) [] expr (const $ Right ()) >>= \case + Left err -> print err + Right (_expr, typ, _hovers) -> do + putStrLn $ Text.unpack $ "\ntype: " <> renderPretty typ + putStrLn $ "\ntype (pretty)" <> (Text.unpack $ renderDoc $ mkPrettyTy prelude mempty typ) + + case traverse parseType inTys of + Left errs -> print errs + Right inTysParsed -> case parseType outTy of + Left errTy -> print errTy + Right outTyParsed -> + case inferTypeReps (allClasses prelude) typ inTysParsed outTyParsed of + Left errTy' -> do + print errTy' + forM_ errTy' $ \e -> print $ inferErrorDiagnostic e + Right res -> do + putStrLn ("type reps:" :: String) + print res + +parseAndInferPossibleTypes :: forall m c. (MonadError EvalError m, Pretty c, Eq c) => ModuleMap m c -> Text -> [Maybe Text] -> Maybe Text -> IO () +parseAndInferPossibleTypes prelude expr inTys outTy = + (parseAndInfer @m @_ @c prelude) [] expr (const $ Right ()) >>= \case + Left err -> print err + Right (_expr, typ, _hovers) -> do + putStrLn $ Text.unpack $ "\ntype: " <> renderPretty typ + putStrLn $ "\ntype (pretty)" <> (Text.unpack $ renderDoc $ mkPrettyTy prelude mempty typ) + + case traverse (maybe (pure Nothing) ((Just <$>) . parseType)) inTys of + Left errs -> print errs + Right inTysParsed -> case (maybe (pure Nothing) ((Just <$>) . parseType)) outTy of + Left errTy -> print errTy + Right outTyParsed -> + case inferPossibleTypes (allClasses prelude) typ inTysParsed outTyParsed of + Left errTy' -> do + print errTy' + forM_ errTy' $ \e -> print $ inferErrorDiagnostic e + Right res -> do + putStrLn ("possible types:" :: String) + print res + +-- putStrLn $ show hovers + +mkHover :: forall m c. (MonadError EvalError m, Pretty c, Eq c) => ModuleMap m c -> Set.Set TypeClass -> (SourcePos, SourcePos) -> TypeMetadata TCScheme -> (Range, MarkupContent) +mkHover prelude currentClasses (s, e) meta@TypeMetadata {identExpr = expr, ty = tcSchTy} = + let prettyTy = mkPrettyTy prelude currentClasses tcSchTy + in ( mkRange ((fromIntegral $ unPos $ sourceLine s) - 2) ((fromIntegral $ unPos $ sourceColumn s) - 1) ((fromIntegral $ unPos $ sourceLine e) - 2) ((fromIntegral $ unPos $ sourceColumn e) - 1), + MarkupContent MkMarkdown $ + "**Type**\n" + <> "~~~inferno\n" + <> (renderDoc $ pretty expr <+> align prettyTy) + <> "\n~~~" + <> (maybe "" ("\n" <>) (getTypeMetadataText meta)) + ) + +mkPrettyTy :: forall m c ann. (MonadError EvalError m, Pretty c, Eq c) => ModuleMap m c -> Set.Set TypeClass -> TCScheme -> Doc ann +mkPrettyTy prelude currentClasses (ForallTC _tvs cls typ) = + let ftvTy = ftv typ + in if Set.null ftvTy + then -- if the body of the type contains no type variables, simply pretty print it + ":" <+> align (pretty typ) + else -- otherwise get a union type by running findTypeClassWitnesses. + -- things to note: + -- * we need to filter out the "rep" typeclass, since it is always defined and thererfore pointless to pass to the solver + -- * we only want to pass in the fvs of typ to the solver, as these are the only type variables we care about displaying + case findTypeClassWitnesses (allClasses prelude) (Just 11) (Set.filter (\case TypeClass "rep" _ -> False; _ -> True) $ Set.union cls currentClasses) ftvTy of + [] -> error "we must always have at least one witness!" + subs -> + let prettyList = map pretty $ nub $ sort $ map (flip apply $ filterOutImplicitTypeReps typ) subs + prettyListMax10 = take 10 prettyList + in if length prettyListMax10 == length prettyList + then (sep $ unionTySig prettyList) + else (sep $ unionTySig $ prettyList <> ["..."]) + where + unionTySig [] = [] + unionTySig (t : ts) = (":" <+> t) : go ts + go [] = [] + go (t : ts) = ("|" <+> t) : go ts + + filterOutImplicitTypeReps (ImplType impls ty) = + ImplType (Map.filter (\case TRep _ -> False; _ -> True) impls) ty + +getTypeMetadataText :: TypeMetadata TCScheme -> Maybe Text +getTypeMetadataText TypeMetadata {docs = tcsDocs, ty = ForallTC _ _ (ImplType _ tcsTy)} = + renderDoc + <$> case (tcsDocs, tcsTy) of + (Nothing, _) -> Nothing + (_, TBase (TEnum nm cs)) -> + Just $ + pretty (fromMaybe "" tcsDocs) + <> hardline + <> "~~~inferno" + <> hardline + <> "enum" + <+> pretty nm + <+> align (sep $ "=" : (punctuate' "|" $ map (("#" <>) . pretty . unIdent) $ Set.toList cs)) + <> hardline + <> "~~~" + _ -> Just $ pretty (fromMaybe "" tcsDocs) diff --git a/src/Inferno/LSP/Server.hs b/src/Inferno/LSP/Server.hs new file mode 100644 --- /dev/null +++ b/src/Inferno/LSP/Server.hs @@ -0,0 +1,371 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE ExplicitNamespaces #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeInType #-} + +module Inferno.LSP.Server where + +import Colog.Core.Action (LogAction (..)) +import Control.Concurrent (forkIO) +import Control.Concurrent.STM.TChan (TChan, newTChan, readTChan, writeTChan) +import Control.Concurrent.STM.TVar (TVar, modifyTVar, newTVar, readTVar) +import qualified Control.Exception as E +import Control.Monad (forever) +import Control.Monad.Except (MonadError) +import Control.Monad.IO.Class (MonadIO (..)) +import Control.Monad.STM (atomically) +import Control.Monad.Trans.Reader (ReaderT (..), ask) +-- import qualified Data.Aeson as J +-- import Data.Int (Int32) +import qualified Data.ByteString as BS +import Data.ByteString.Builder.Extra (defaultChunkSize) +import qualified Data.ByteString.Lazy as BSL +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Maybe (catMaybes, fromMaybe) +import qualified Data.Text as T +import qualified Data.Text.Utf16.Rope as Rope +import Data.Time.Clock (UTCTime, getCurrentTime) +import qualified Data.UUID.V4 as UUID.V4 +import Inferno.Eval.Error (EvalError) +import Inferno.LSP.Completion (completionQueryAt, filterModuleNameCompletionItems, findInPrelude, identifierCompletionItems, mkCompletionItem, rwsCompletionItems) +import Inferno.LSP.ParseInfer (parseAndInfer) +import Inferno.Module.Prelude (ModuleMap, preludeNameToTypeMap) +import Inferno.Types.Syntax (Expr, Ident (..), InfernoType) +import Inferno.Types.Type (TCScheme) +import Inferno.Types.VersionControl (Pinned) +import Inferno.VersionControl.Types (VCObjectHash) +import Keys.UUID (UUID (..)) +import Language.LSP.Diagnostics (partitionBySource) +import Language.LSP.Server + ( Handler, + Handlers (..), + LspT (..), + Options (..), + ServerDefinition (..), + defaultOptions, + getLspEnv, + getVirtualFile, + mapHandlers, + notificationHandler, + publishDiagnostics, + requestHandler, + runLspT, + runServerWith, + type (<~>) (Iso), + ) +import qualified Language.LSP.Types as J +import qualified Language.LSP.Types.Lens as J +import Language.LSP.VFS (VirtualFile (..)) +import Lens.Micro (to, (^.)) +import Plow.Logging (IOTracer (..), traceWith) +import Plow.Logging.Async (withAsyncHandleTracer) +import Prettyprinter (Pretty) +import System.IO (BufferMode (NoBuffering), hFlush, hSetBuffering, hSetEncoding, stdin, stdout, utf8) + +-- import System.Exit + +-- This is the entry point for launching an LSP server, explicitly passing in handles for input and output +-- the `getIdents` parameter is a handle for input parameters, only used by the frontend. +-- This is used in the script editor, where the user only specifies the body of the script in the editor +-- and defines the input arguments separately in the sidebar. When processing in the LSP server, we have to +-- manually join the body of the script coming from the monaco editor with the parameters. i.e. if the user +-- specifies parameters ["a", "b"] and the body of the script is "a + b", then we will pass "fun a b -> a + b" +-- to the inferno typechecker. +runInfernoLspServerWith :: + forall m c. + (MonadError EvalError m, Pretty c, Eq c) => + IOTracer T.Text -> + IO BS.ByteString -> + (BSL.ByteString -> IO ()) -> + ModuleMap m c -> + IO [Maybe Ident] -> + (InfernoType -> Either T.Text ()) -> + -- | Action to run before start parsing + ((UUID, UTCTime) -> IO ()) -> + -- | Action to run after parsing is done + ((UUID, UTCTime) -> ParsedResult -> IO ParsedResult) -> + IO Int +runInfernoLspServerWith tracer clientIn clientOut prelude getIdents validateInput before after = flip E.catches handlers $ do + rin <- atomically newTChan :: IO (TChan ReactorInput) + docMap <- atomically $ newTVar mempty + let infernoEnv = InfernoEnv docMap tracer getIdents before after validateInput + + let serverDefinition = + ServerDefinition + { defaultConfig = (), + onConfigurationChange = \old _v -> Right old, + doInitialize = \env _ -> forkIO (reactor tracer rin) >> pure (Right env), + staticHandlers = lspHandlers @m @c prelude rin, + interpretHandler = \env -> Iso (flip runReaderT infernoEnv . runLspT env) liftIO, + options = lspOptions + } + + let serverTracer = traceWith tracer . T.pack . show + i <- runServerWith (LogAction serverTracer) (LogAction (liftIO . serverTracer)) clientIn clientOut serverDefinition + traceWith tracer "shutting down..." + pure i + where + handlers = + [ E.Handler ioExcept, + E.Handler someExcept + ] + ioExcept (e :: E.IOException) = traceWith tracer (T.pack (show e)) >> return 1 + someExcept (e :: E.SomeException) = traceWith tracer (T.pack (show e)) >> return 1 + +runInfernoLspServer :: forall m c. (MonadError EvalError m, Pretty c, Eq c) => ModuleMap m c -> IO Int +runInfernoLspServer prelude = do + hSetBuffering stdin NoBuffering + hSetEncoding stdin utf8 + + hSetBuffering stdout NoBuffering + hSetEncoding stdout utf8 + + let clientIn = BS.hGetSome stdin defaultChunkSize + + clientOut out = do + BSL.hPut stdout out + hFlush stdout + getIdents = pure [] + + withAsyncHandleTracer stdout 100 $ \tracer -> do + let beforeParse _ = pure () + afterParse _ = pure + runInfernoLspServerWith @m @c tracer clientIn clientOut prelude getIdents (const $ Right ()) beforeParse afterParse + +-- --------------------------------------------------------------------- + +syncOptions :: J.TextDocumentSyncOptions +syncOptions = + J.TextDocumentSyncOptions + { J._openClose = Just True, + J._change = Just J.TdSyncIncremental, + J._willSave = Just False, + J._willSaveWaitUntil = Just False, + J._save = Just $ J.InR $ J.SaveOptions $ Just False + } + +lspOptions :: Options +lspOptions = + defaultOptions + { textDocumentSync = Just syncOptions, + executeCommandCommands = Nothing + } + +-- --------------------------------------------------------------------- + +-- The reactor is a process that serialises and buffers all requests from the +-- LSP client, so they can be sent to the backend compiler one at a time, and a +-- reply sent. + +-- | Helper type to reduce typing +type ParsedResult = Either [J.Diagnostic] (Expr (Pinned VCObjectHash) (), TCScheme, [(J.Range, J.MarkupContent)]) + +withParseAndInfer :: MonadIO m => ((UUID, UTCTime) -> m ()) -> ((UUID, UTCTime) -> ParsedResult -> m ParsedResult) -> m ParsedResult -> m ParsedResult +withParseAndInfer before after action = do + ts <- liftIO getCurrentTime + uuid <- UUID <$> liftIO UUID.V4.nextRandom + + before (uuid, ts) + result <- action + after (uuid, ts) result + +data InfernoEnv = InfernoEnv + { hovers :: TVar (Map (J.NormalizedUri, J.Int32) [(J.Range, J.MarkupContent)]), + tracer :: IOTracer T.Text, + getIdents :: IO [Maybe Ident], + -- | Action to run before start parsing + beforeParse :: (UUID, UTCTime) -> IO (), + -- | Action to run after parsing is done + afterParse :: (UUID, UTCTime) -> ParsedResult -> IO ParsedResult, + -- | If you don't care about the input type use (const $ Right ()) + validateInput :: InfernoType -> Either T.Text () + } + +type InfernoLspM = LspT () (ReaderT InfernoEnv IO) + +newtype ReactorInput + = ReactorAction (IO ()) + +-- --------------------------------------------------------------------- + +-- | The single point that all events flow through, allowing management of state +-- to stitch replies and requests together from the two asynchronous sides: lsp +-- server and backend compiler +reactor :: IOTracer T.Text -> TChan ReactorInput -> IO () +reactor tracer inp = do + traceWith tracer "Started the reactor" + forever $ do + ReactorAction act <- atomically $ readTChan inp + act + +getInfernoEnv :: InfernoLspM InfernoEnv +getInfernoEnv = LspT $ ReaderT $ \_ -> ask + +trace :: String -> InfernoLspM () +trace s = LspT $ + ReaderT $ \_ -> do + InfernoEnv {tracer} <- ask + traceWith tracer (T.pack s) + +sendDiagnostics :: J.NormalizedUri -> J.TextDocumentVersion -> [J.Diagnostic] -> InfernoLspM () +sendDiagnostics fileUri version diags = + publishDiagnostics 100 fileUri version (partitionBySource diags) + +-- | Check if we have a handler, and if we create a haskell-lsp handler to pass it as +-- input into the reactor +lspHandlers :: forall m c. (MonadError EvalError m, Pretty c, Eq c) => ModuleMap m c -> TChan ReactorInput -> Handlers InfernoLspM +lspHandlers prelude rin = mapHandlers goReq goNot (handle @m @c prelude) + where + goReq :: forall (a :: J.Method 'J.FromClient 'J.Request). Handler InfernoLspM a -> Handler InfernoLspM a + goReq f = \msg k -> do + env <- getLspEnv + infernoEnv <- getInfernoEnv + liftIO $ atomically $ writeTChan rin $ ReactorAction (flip runReaderT infernoEnv $ runLspT env $ f msg k) + + goNot :: forall (a :: J.Method 'J.FromClient 'J.Notification). Handler InfernoLspM a -> Handler InfernoLspM a + goNot f = \msg -> do + env <- getLspEnv + infernoEnv <- getInfernoEnv + liftIO $ atomically $ writeTChan rin $ ReactorAction (flip runReaderT infernoEnv $ runLspT env $ f msg) + +-- | Where the actual logic resides for handling requests and notifications. +handle :: forall m c. (MonadError EvalError m, Pretty c, Eq c) => ModuleMap m c -> Handlers InfernoLspM +handle prelude = + mconcat + [ notificationHandler J.STextDocumentDidOpen $ \msg -> do + InfernoEnv {hovers = hoversTV, getIdents, beforeParse, afterParse, validateInput} <- getInfernoEnv + let doc_uri = msg ^. J.params . J.textDocument . J.uri . to J.toNormalizedUri + doc_txt = msg ^. J.params . J.textDocument . J.text + idents <- liftIO getIdents + trace $ "Processing DidOpenTextDocument for: " ++ show doc_uri + hovers <- + withParseAndInfer (liftIO . beforeParse) (\x y -> liftIO $ afterParse x y) (parseAndInfer @m @_ @c prelude idents doc_txt validateInput) >>= \case + Left errs -> do + sendDiagnostics doc_uri (Just 0) errs + pure mempty + Right (_expr, _ty, hovers) -> do + trace $ "Created hovers for: " ++ show doc_uri + sendDiagnostics doc_uri (Just 0) [] + pure hovers + + doc_version <- + getVirtualFile doc_uri >>= \case + Just (VirtualFile doc_version _ _) -> pure doc_version + Nothing -> pure 0 -- Maybe a good default? + liftIO $ atomically $ modifyTVar hoversTV $ \hoversMap -> Map.insert (doc_uri, doc_version) hovers hoversMap, + notificationHandler J.STextDocumentDidChange $ \msg -> do + InfernoEnv {hovers = hoversTV, getIdents, beforeParse, afterParse, validateInput} <- getInfernoEnv + let doc_uri = + msg + ^. J.params + . J.textDocument + . J.uri + . to J.toNormalizedUri + getVirtualFile doc_uri >>= \case + Just (VirtualFile doc_version _ rope) -> do + let txt = Rope.toText rope + trace $ "Processing DidChangeTextDocument for: " ++ show doc_uri ++ " - " ++ show doc_version + idents <- liftIO getIdents + hovers <- + withParseAndInfer (liftIO . beforeParse) (\x y -> liftIO $ afterParse x y) (parseAndInfer @m @_ @c prelude idents txt validateInput) >>= \case + Left errs -> do + trace $ "Sending errs: " ++ show errs + sendDiagnostics doc_uri (Just doc_version) errs + pure mempty + Right (_expr, _ty, hovers) -> do + trace $ "Updated hovers for: " ++ show doc_uri ++ " - " ++ show doc_version + sendDiagnostics doc_uri (Just doc_version) [] + pure hovers + trace $ "Setting hovers: " ++ show hovers + liftIO $ atomically $ modifyTVar hoversTV $ \hoversMap -> Map.insert (doc_uri, doc_version) hovers hoversMap + Nothing -> pure (), + requestHandler J.STextDocumentCompletion $ \req responder -> do + InfernoEnv {getIdents} <- getInfernoEnv + let doc_uri = req ^. J.params . J.textDocument . J.uri . to J.toNormalizedUri + pos = req ^. J.params . J.position + + completionPrefix <- + getVirtualFile doc_uri >>= \case + Just (VirtualFile _ _ rope) -> do + let txt = Rope.toText rope + let (_completionLeadup, completionPrefix) = completionQueryAt txt pos + pure $ Just completionPrefix + Nothing -> pure Nothing + trace $ "Completion prefix: " <> show completionPrefix + mIdents <- liftIO $ getIdents + let completions = maybe [] id $ findInPrelude @c (preludeNameToTypeMap prelude) <$> completionPrefix + idents = unIdent <$> catMaybes mIdents + identCompletions = maybe [] id $ identifierCompletionItems idents <$> completionPrefix + rwsCompletions = maybe [] id $ rwsCompletionItems <$> completionPrefix + moduleCompletions = maybe [] id $ filterModuleNameCompletionItems @c (preludeNameToTypeMap prelude) <$> completionPrefix + allCompletions = rwsCompletions ++ moduleCompletions ++ identCompletions ++ map (uncurry $ mkCompletionItem prelude $ fromMaybe "" completionPrefix) completions + + trace $ "Ident completions: " <> show identCompletions + trace $ "Found completions: " <> show completions + + responder $ Right $ J.InL $ J.List $ allCompletions, + requestHandler J.STextDocumentHover $ \req responder -> do + InfernoEnv {hovers = hoversTV} <- getInfernoEnv + trace "Processing a textDocument/hover request" + let J.Position l c = req ^. J.params . J.position + doc_uri = + req + ^. J.params + . J.textDocument + . J.uri + . to J.toNormalizedUri + + mDoc_version <- + getVirtualFile doc_uri >>= \case + Just (VirtualFile doc_version _ _) -> pure $ Just doc_version + Nothing -> pure Nothing + + hoversMap <- liftIO $ atomically $ readTVar hoversTV + responder $ + Right $ case mDoc_version of + Just doc_version -> case Map.lookup (doc_uri, doc_version) hoversMap of + Just hovers -> + (\(r, t) -> J.Hover (J.HoverContents t) (Just r)) + <$> ( findSmallestRange $ + flip filter hovers $ + \(J.Range (J.Position lStart cStart) (J.Position lEnd cEnd), _) -> + if l < lStart || l > lEnd + then False + else + if l == lStart && c < cStart + then False + else + if l == lEnd && c > cEnd + then False + else True + ) + Nothing -> Nothing + Nothing -> Nothing + ] + +findSmallestRange :: [(J.Range, a)] -> Maybe (J.Range, a) +findSmallestRange = \case + [] -> Nothing + (r : rs) -> Just $ foldr (\x@(a, _) y@(b, _) -> if a `containsRange` b then y else x) r rs + where + containsRange + (J.Range (J.Position aStartLine aStartColumn) (J.Position aEndLine aEndColumn)) + (J.Range (J.Position bStartLine bStartColumn) (J.Position bEndLine bEndColumn)) = + if bStartLine < aStartLine || bEndLine < aStartLine + then False + else + if bStartLine > aEndLine || bEndLine > aEndLine + then False + else + if bStartLine == aStartLine && bStartColumn < aStartColumn + then False + else + if bEndLine == aEndLine && bEndColumn > aEndColumn + then False + else True