inferno-lsp (empty) → 0.1.0
raw patch · 7 files changed
+1408/−0 lines, 7 filesdep +basedep +bytestringdep +co-log-core
Dependencies added: base, bytestring, co-log-core, containers, inferno-core, inferno-types, inferno-vc, lsp, lsp-types, megaparsec, microlens, mtl, plow-log, plow-log-async, prettyprinter, safe, special-keys, stm, text, text-rope, time, transformers, uuid
Files
- CHANGELOG.md +4/−0
- LICENSE +21/−0
- app/Main.hs +15/−0
- inferno-lsp.cabal +73/−0
- src/Inferno/LSP/Completion.hs +228/−0
- src/Inferno/LSP/ParseInfer.hs +696/−0
- src/Inferno/LSP/Server.hs +371/−0
+ CHANGELOG.md view
@@ -0,0 +1,4 @@+# Revision History for inferno-lsp++## 0.1.0.0 -- 2022-11-28+* Prepare for OSS release
+ LICENSE view
@@ -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.
+ app/Main.hs view
@@ -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
+ inferno-lsp.cabal view
@@ -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
+ src/Inferno/LSP/Completion.hs view
@@ -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)
+ src/Inferno/LSP/ParseInfer.hs view
@@ -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)
+ src/Inferno/LSP/Server.hs view
@@ -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