├── .editorconfig ├── .github └── workflows │ ├── build.yml │ └── deploy.yml ├── .gitignore ├── .hlint.yaml ├── LICENSE ├── README.md ├── Setup.hs ├── app └── Main.hs ├── curry-language-server.cabal ├── hie.yaml ├── images ├── logo.svg └── screenshot.png ├── package.yaml ├── scripts └── make-bindist ├── src └── Curry │ └── LanguageServer │ ├── CPM │ ├── Deps.hs │ ├── Monad.hs │ └── Process.hs │ ├── Compiler.hs │ ├── Config.hs │ ├── Extension.hs │ ├── FileLoader.hs │ ├── Handlers.hs │ ├── Handlers │ ├── Cancel.hs │ ├── Config.hs │ ├── Diagnostics.hs │ ├── Initialize.hs │ ├── TextDocument │ │ ├── CodeAction.hs │ │ ├── CodeLens.hs │ │ ├── Completion.hs │ │ ├── Definition.hs │ │ ├── DocumentSymbol.hs │ │ ├── Hover.hs │ │ ├── Notifications.hs │ │ ├── References.hs │ │ └── SignatureHelp.hs │ └── Workspace │ │ ├── Command.hs │ │ └── Symbol.hs │ ├── Index │ ├── Convert.hs │ ├── Resolve.hs │ ├── Store.hs │ └── Symbol.hs │ ├── Monad.hs │ └── Utils │ ├── Concurrent.hs │ ├── Convert.hs │ ├── General.hs │ ├── Logging.hs │ ├── Lookup.hs │ ├── Sema.hs │ ├── Syntax.hs │ ├── Uri.hs │ └── VFS.hs ├── stack.yaml ├── stack.yaml.lock └── test ├── Spec.hs └── resources ├── Demo.curry └── Test.curry /.editorconfig: -------------------------------------------------------------------------------- 1 | # top-most EditorConfig file 2 | root = true 3 | 4 | [*] 5 | indent_style = space 6 | indent_size = 4 7 | end_of_line = lf 8 | charset = utf-8 9 | trim_trailing_whitespace = false 10 | insert_final_newline = true 11 | 12 | [*.{yml,yaml,cabal}] 13 | indent_size = 2 14 | -------------------------------------------------------------------------------- /.github/workflows/build.yml: -------------------------------------------------------------------------------- 1 | name: Build 2 | 3 | on: 4 | push: 5 | branches: 6 | - main 7 | pull_request: 8 | workflow_dispatch: 9 | 10 | jobs: 11 | build: 12 | strategy: 13 | matrix: 14 | os: [ubuntu-latest, macos-latest, windows-latest] 15 | 16 | runs-on: ${{ matrix.os }} 17 | steps: 18 | - uses: actions/checkout@v4 19 | - name: Set up Haskell and Stack 20 | uses: haskell-actions/setup@v2 21 | with: 22 | enable-stack: true 23 | stack-version: 'latest' 24 | - name: Build 25 | run: stack build 26 | -------------------------------------------------------------------------------- /.github/workflows/deploy.yml: -------------------------------------------------------------------------------- 1 | name: Deploy 2 | 3 | on: 4 | push: 5 | tags: 6 | - '*' 7 | workflow_dispatch: 8 | 9 | jobs: 10 | release: 11 | runs-on: ubuntu-latest 12 | outputs: 13 | tag: ${{ steps.tag.outputs.tag }} 14 | steps: 15 | - name: Get tag name 16 | id: tag 17 | run: | 18 | tag=$(basename "${{ github.ref }}") 19 | echo "tag=$tag" >> $GITHUB_OUTPUT 20 | - name: Create release 21 | env: 22 | GH_TOKEN: ${{ github.token }} 23 | GH_REPO: ${{ github.repository }} 24 | run: | 25 | tag="${{ steps.tag.outputs.tag }}" 26 | echo "Tag: $tag" 27 | gh release create "$tag" --title "$tag" 28 | 29 | build: 30 | strategy: 31 | matrix: 32 | os: [ubuntu-latest, macos-13, macos-latest, windows-latest] 33 | 34 | needs: [release] 35 | runs-on: ${{ matrix.os }} 36 | steps: 37 | - uses: actions/checkout@v4 38 | - name: Set up Haskell and Stack 39 | uses: haskell-actions/setup@v2 40 | with: 41 | enable-stack: true 42 | stack-version: 'latest' 43 | - name: Build and archive 44 | shell: bash 45 | run: scripts/make-bindist 46 | - name: Upload 47 | env: 48 | GH_TOKEN: ${{ github.token }} 49 | GH_REPO: ${{ github.repository }} 50 | shell: bash 51 | run: | 52 | shopt -s nullglob 53 | gh release upload "${{ needs.release.outputs.tag }}" bindists/*.{tar.gz,zip} 54 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .vscode 2 | .DS_Store 3 | .stack-work 4 | dist 5 | dist-newstyle 6 | bin 7 | bindists 8 | .curry 9 | *~ 10 | *.log 11 | -------------------------------------------------------------------------------- /.hlint.yaml: -------------------------------------------------------------------------------- 1 | - ignore: { name: "Functor law" } 2 | - ignore: { name: "Move brackets to avoid $" } 3 | - ignore: { name: "Use <=<" } 4 | - ignore: { name: "Use record patterns" } 5 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright fwcd (c) 2020-2025 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of fwcd nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Curry Language Server 2 | 3 | 4 | 5 | [![Build](https://github.com/fwcd/curry-language-server/actions/workflows/build.yml/badge.svg)](https://github.com/fwcd/curry-language-server/actions/workflows/build.yml) 6 | ![Haskell](https://img.shields.io/badge/language-Haskell-7363a3.svg) 7 | ![BSD3 License](https://img.shields.io/badge/license-BSD3-333333.svg) 8 | 9 | An experimental [language server](https://microsoft.github.io/language-server-protocol/) providing IDE support for the functional logic programming language [Curry](https://en.wikipedia.org/wiki/Curry_(programming_language)). 10 | 11 | ![Screenshot](images/screenshot.png) 12 | 13 | ## Building 14 | 15 | To build the language server, you will need the build tool [Haskell Stack](https://docs.haskellstack.org). Once installed, you can run `stack build` to build the language server. 16 | 17 | The final executable will be located in `$(stack path --dist-dir)/build/curry-language-server`. 18 | 19 | If you wish to use the language server in an editor, you can also use `stack install` to install the binary into `~/.local/bin`. By adding this directory to your `PATH`, invoking `curry-language-server` will work from any directory. 20 | 21 | ## Editor Integration 22 | 23 | To use the language server, you will need an editor that supports LSP. This usually involves pointing the LSP client towards the built executable and setting the transport method to `stdio`. 24 | 25 | For Visual Studio Code, [this extension](https://github.com/fwcd/vscode-curry) can be used. 26 | 27 | ## Known Issues 28 | 29 | If the language server has trouble locating an interface for the `Prelude`, you may need to add your Curry compiler's `lib` directory to your import paths, e.g. in your config under `curry.languageServer.importPaths` or in `/.curry/language-server/paths.json` (which is a string array of import paths). Alternatively, you may also place a compiled version (`Prelude.icurry`) in the folder `/.curry/language-server`. 30 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /app/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase, ScopedTypeVariables, OverloadedStrings #-} 2 | module Main where 3 | 4 | import Colog.Core (LogAction (..), WithSeverity (..)) 5 | import Control.Monad.IO.Class (liftIO) 6 | import qualified Data.Aeson as A 7 | import Data.Default (Default (..)) 8 | import qualified Data.Text as T 9 | import qualified Language.LSP.Server as S 10 | import qualified Language.LSP.Protocol.Types as J 11 | import qualified Curry.LanguageServer.Config as CFG 12 | import Curry.LanguageServer.Handlers 13 | import Curry.LanguageServer.Handlers.Config (onConfigChange) 14 | import Curry.LanguageServer.Handlers.Initialize (initializeHandler) 15 | import Curry.LanguageServer.Handlers.Workspace.Command (commands) 16 | import Curry.LanguageServer.Monad (runLSM, newLSStateVar) 17 | import System.Exit (ExitCode(ExitFailure), exitSuccess, exitWith) 18 | import System.IO (stdin, stdout) 19 | 20 | main :: IO () 21 | main = runLanguageServer >>= \case 22 | 0 -> exitSuccess 23 | c -> exitWith $ ExitFailure c 24 | 25 | runLanguageServer :: IO Int 26 | runLanguageServer = do 27 | state <- newLSStateVar 28 | S.runServerWithHandles logger logger stdin stdout $ S.ServerDefinition 29 | { S.defaultConfig = def 30 | , S.parseConfig = \_old v -> case A.fromJSON v of 31 | A.Error e -> Left $ T.pack e 32 | A.Success cfg -> Right (cfg :: CFG.Config) 33 | , S.configSection = "curry.languageServer" 34 | , S.onConfigChange = onConfigChange 35 | , S.doInitialize = \env req -> runLSM (initializeHandler req) state env >> return (Right env) 36 | , S.staticHandlers = handlers 37 | , S.interpretHandler = \env -> S.Iso (\lsm -> runLSM lsm state env) liftIO 38 | , S.options = S.defaultOptions 39 | { S.optTextDocumentSync = Just syncOptions 40 | , S.optCompletionTriggerCharacters = Just ['.'] 41 | , S.optSignatureHelpTriggerCharacters = Just [' ', '(', ')'] 42 | , S.optExecuteCommandCommands = Just $ fst <$> commands 43 | , S.optServerInfo = Just $ J.ServerInfo "Curry Language Server" Nothing 44 | } 45 | } 46 | where 47 | -- We discard log messages originating from the LSP framework for now, 48 | -- since logging every JSON-RPC message makes the output hard to read. 49 | -- Eventually we may want to filter by severity (e.g. >= Info) or define 50 | -- our own `pretty :: LspServerLog -> Text`, similar to 51 | -- https://github.com/haskell/lsp/blob/7c1fcaa1073dc79e6b330b06e34d30b5d0045af6/lsp/src/Language/LSP/Server/Control.hs#L56-L71 52 | -- and filter out all the cases that we do not care about (e.g. ParsedMsg, SendMsg). 53 | logger :: Monad m => LogAction m (WithSeverity S.LspServerLog) 54 | logger = LogAction $ const $ return () 55 | syncOptions = J.TextDocumentSyncOptions 56 | (Just True) -- open/close notifications 57 | (Just J.TextDocumentSyncKind_Incremental) -- changes 58 | (Just False) -- will save 59 | (Just False) -- will save (wait until requests are sent to server) 60 | (Just $ J.InR $ J.SaveOptions $ Just False) -- save 61 | -------------------------------------------------------------------------------- /curry-language-server.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 1.12 2 | 3 | -- This file has been generated from package.yaml by hpack version 0.37.0. 4 | -- 5 | -- see: https://github.com/sol/hpack 6 | 7 | name: curry-language-server 8 | version: 1.0.0.5 9 | synopsis: IDE support for the functional-logic language Curry 10 | description: Please see the README on GitHub at 11 | category: Development 12 | homepage: https://github.com/fwcd/curry-language-server#readme 13 | bug-reports: https://github.com/fwcd/curry-language-server/issues 14 | author: fwcd 15 | maintainer: fwcd 16 | copyright: 2020-2025 fwcd 17 | license: BSD3 18 | license-file: LICENSE 19 | build-type: Simple 20 | extra-source-files: 21 | README.md 22 | 23 | source-repository head 24 | type: git 25 | location: https://github.com/fwcd/curry-language-server 26 | 27 | library 28 | exposed-modules: 29 | Curry.LanguageServer.Compiler 30 | Curry.LanguageServer.Config 31 | Curry.LanguageServer.CPM.Deps 32 | Curry.LanguageServer.CPM.Monad 33 | Curry.LanguageServer.CPM.Process 34 | Curry.LanguageServer.Extension 35 | Curry.LanguageServer.FileLoader 36 | Curry.LanguageServer.Handlers 37 | Curry.LanguageServer.Handlers.Cancel 38 | Curry.LanguageServer.Handlers.Config 39 | Curry.LanguageServer.Handlers.Diagnostics 40 | Curry.LanguageServer.Handlers.Initialize 41 | Curry.LanguageServer.Handlers.TextDocument.CodeAction 42 | Curry.LanguageServer.Handlers.TextDocument.CodeLens 43 | Curry.LanguageServer.Handlers.TextDocument.Completion 44 | Curry.LanguageServer.Handlers.TextDocument.Definition 45 | Curry.LanguageServer.Handlers.TextDocument.DocumentSymbol 46 | Curry.LanguageServer.Handlers.TextDocument.Hover 47 | Curry.LanguageServer.Handlers.TextDocument.Notifications 48 | Curry.LanguageServer.Handlers.TextDocument.References 49 | Curry.LanguageServer.Handlers.TextDocument.SignatureHelp 50 | Curry.LanguageServer.Handlers.Workspace.Command 51 | Curry.LanguageServer.Handlers.Workspace.Symbol 52 | Curry.LanguageServer.Index.Convert 53 | Curry.LanguageServer.Index.Resolve 54 | Curry.LanguageServer.Index.Store 55 | Curry.LanguageServer.Index.Symbol 56 | Curry.LanguageServer.Monad 57 | Curry.LanguageServer.Utils.Concurrent 58 | Curry.LanguageServer.Utils.Convert 59 | Curry.LanguageServer.Utils.General 60 | Curry.LanguageServer.Utils.Logging 61 | Curry.LanguageServer.Utils.Lookup 62 | Curry.LanguageServer.Utils.Sema 63 | Curry.LanguageServer.Utils.Syntax 64 | Curry.LanguageServer.Utils.Uri 65 | Curry.LanguageServer.Utils.VFS 66 | other-modules: 67 | Paths_curry_language_server 68 | hs-source-dirs: 69 | src 70 | ghc-options: -Wall 71 | build-depends: 72 | Glob ==0.10.* 73 | , aeson ==2.2.* 74 | , async ==2.2.* 75 | , base >=4.16 && <4.19 76 | , bytestring >=0.11 && <0.13 77 | , bytestring-trie ==0.2.* 78 | , co-log-core ==0.3.* 79 | , containers >=0.6 && <0.8 80 | , curry-frontend 81 | , data-default ==0.7.* 82 | , directory ==1.3.* 83 | , either >=5.0 && <6 84 | , exceptions ==0.10.* 85 | , extra >=1.7 && <1.9 86 | , filepath ==1.4.* 87 | , lens >=5.1 && <5.3 88 | , lsp ==2.7.* 89 | , mtl >=2.2 && <2.4 90 | , parsec >=3.1 && <4 91 | , pretty ==1.1.* 92 | , process >=1.6 && <2 93 | , sorted-list ==0.2.* 94 | , stm ==2.5.* 95 | , text >=2.0 && <2.2 96 | , text-rope ==0.2.* 97 | , transformers >=0.5 && <0.7 98 | , unliftio-core ==0.2.* 99 | default-language: Haskell2010 100 | 101 | executable curry-language-server 102 | main-is: Main.hs 103 | other-modules: 104 | Paths_curry_language_server 105 | hs-source-dirs: 106 | app 107 | ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall 108 | build-depends: 109 | Glob ==0.10.* 110 | , aeson ==2.2.* 111 | , async ==2.2.* 112 | , base >=4.16 && <4.19 113 | , bytestring >=0.11 && <0.13 114 | , bytestring-trie ==0.2.* 115 | , co-log-core ==0.3.* 116 | , containers >=0.6 && <0.8 117 | , curry-frontend 118 | , curry-language-server 119 | , data-default ==0.7.* 120 | , directory ==1.3.* 121 | , either >=5.0 && <6 122 | , exceptions ==0.10.* 123 | , extra >=1.7 && <1.9 124 | , filepath ==1.4.* 125 | , lens >=5.1 && <5.3 126 | , lsp ==2.7.* 127 | , mtl >=2.2 && <2.4 128 | , parsec >=3.1 && <4 129 | , pretty ==1.1.* 130 | , process >=1.6 && <2 131 | , sorted-list ==0.2.* 132 | , stm ==2.5.* 133 | , text >=2.0 && <2.2 134 | , text-rope ==0.2.* 135 | , transformers >=0.5 && <0.7 136 | , unliftio-core ==0.2.* 137 | default-language: Haskell2010 138 | 139 | test-suite curry-language-server-test 140 | type: exitcode-stdio-1.0 141 | main-is: Spec.hs 142 | other-modules: 143 | Paths_curry_language_server 144 | hs-source-dirs: 145 | test 146 | ghc-options: -threaded -rtsopts -with-rtsopts=-N 147 | build-depends: 148 | Glob ==0.10.* 149 | , aeson ==2.2.* 150 | , async ==2.2.* 151 | , base >=4.16 && <4.19 152 | , bytestring >=0.11 && <0.13 153 | , bytestring-trie ==0.2.* 154 | , co-log-core ==0.3.* 155 | , containers >=0.6 && <0.8 156 | , curry-frontend 157 | , curry-language-server 158 | , data-default ==0.7.* 159 | , directory ==1.3.* 160 | , either >=5.0 && <6 161 | , exceptions ==0.10.* 162 | , extra >=1.7 && <1.9 163 | , filepath ==1.4.* 164 | , lens >=5.1 && <5.3 165 | , lsp ==2.7.* 166 | , mtl >=2.2 && <2.4 167 | , parsec >=3.1 && <4 168 | , pretty ==1.1.* 169 | , process >=1.6 && <2 170 | , sorted-list ==0.2.* 171 | , stm ==2.5.* 172 | , text >=2.0 && <2.2 173 | , text-rope ==0.2.* 174 | , transformers >=0.5 && <0.7 175 | , unliftio-core ==0.2.* 176 | default-language: Haskell2010 177 | -------------------------------------------------------------------------------- /hie.yaml: -------------------------------------------------------------------------------- 1 | cradle: 2 | stack: 3 | -------------------------------------------------------------------------------- /images/logo.svg: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 20 | 22 | 25 | 29 | 33 | 34 | 37 | 41 | 45 | 46 | 55 | 64 | 65 | 88 | 90 | 91 | 93 | image/svg+xml 94 | 96 | 97 | 98 | 99 | 100 | 105 | 108 | 113 | 118 | 121 | 126 | 131 | 136 | 141 | Sandra Dylus &Jan Christiansen 157 | 158 | 159 | 163 | 164 | 165 | -------------------------------------------------------------------------------- /images/screenshot.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/fwcd/curry-language-server/d6b0f218b0065d4bf587348a03366c55d2bec41a/images/screenshot.png -------------------------------------------------------------------------------- /package.yaml: -------------------------------------------------------------------------------- 1 | name: curry-language-server 2 | version: 1.0.0.5 3 | github: "fwcd/curry-language-server" 4 | license: BSD3 5 | author: "fwcd" 6 | copyright: "2020-2025 fwcd" 7 | 8 | synopsis: IDE support for the functional-logic language Curry 9 | category: Development 10 | description: Please see the README on GitHub at 11 | 12 | extra-source-files: 13 | - README.md 14 | 15 | dependencies: 16 | - base >= 4.16 && < 4.19 17 | - aeson >= 2.2 && < 2.3 18 | - async >= 2.2 && < 2.3 19 | - containers >= 0.6 && < 0.8 20 | - data-default >= 0.7 && < 0.8 21 | - extra >= 1.7 && < 1.9 22 | - either >= 5.0 && < 6 23 | - mtl >= 2.2 && < 2.4 24 | - transformers >= 0.5 && < 0.7 25 | - exceptions >= 0.10 && < 0.11 26 | - stm >= 2.5 && < 2.6 27 | - text >= 2.0 && < 2.2 28 | - text-rope >= 0.2 && < 0.3 29 | - lens >= 5.1 && < 5.3 30 | - co-log-core >= 0.3 && < 0.4 31 | - filepath >= 1.4 && < 1.5 32 | - Glob >= 0.10 && < 0.11 33 | - directory >= 1.3 && < 1.4 34 | - sorted-list >= 0.2 && < 0.3 35 | - lsp >= 2.7 && < 2.8 36 | - unliftio-core >= 0.2 && < 0.3 37 | - bytestring >= 0.11 && < 0.13 38 | - bytestring-trie >= 0.2 && < 0.3 39 | - process >= 1.6 && < 2 40 | - parsec >= 3.1 && < 4 41 | - pretty >= 1.1 && < 1.2 42 | - curry-frontend 43 | 44 | library: 45 | source-dirs: src 46 | ghc-options: 47 | - -Wall 48 | 49 | executables: 50 | curry-language-server: 51 | main: Main.hs 52 | source-dirs: app 53 | ghc-options: 54 | - -threaded 55 | - -rtsopts 56 | - -with-rtsopts=-N 57 | - -Wall 58 | dependencies: 59 | - curry-language-server 60 | 61 | tests: 62 | curry-language-server-test: 63 | main: Spec.hs 64 | source-dirs: test 65 | ghc-options: 66 | - -threaded 67 | - -rtsopts 68 | - -with-rtsopts=-N 69 | dependencies: 70 | - curry-language-server 71 | -------------------------------------------------------------------------------- /scripts/make-bindist: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env python3 2 | 3 | from pathlib import Path 4 | 5 | import argparse 6 | import platform 7 | import shutil 8 | import subprocess 9 | import zipfile 10 | 11 | ROOT_DIR = Path(__file__).resolve().parent.parent 12 | 13 | def main(): 14 | parser = argparse.ArgumentParser(description='Creates a binary distribution of the language server') 15 | parser.add_argument('-f', '--format', type=str, default='zip' if platform.system() == 'Windows' else 'gztar', help='The format of the output archive.') 16 | parser.add_argument('-o', '--output', type=Path, default=ROOT_DIR / 'bindists' / f'curry-language-server-{platform.machine().lower()}-{platform.system().lower()}', help='The name of the output archive.') 17 | 18 | args = parser.parse_args() 19 | format: str = args.format 20 | output: Path = args.output 21 | 22 | output.mkdir(parents=True, exist_ok=True) 23 | 24 | print('==> Building...') 25 | subprocess.run(['stack', 'install', '--local-bin-path', output / 'bin'], check=True, cwd=ROOT_DIR) 26 | 27 | print('==> Packaging...') 28 | shutil.copy('LICENSE', output) 29 | 30 | print('==> Archiving...') 31 | shutil.make_archive(output, format, output.parent, output.name) 32 | 33 | if __name__ == '__main__': 34 | main() 35 | -------------------------------------------------------------------------------- /src/Curry/LanguageServer/CPM/Deps.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeApplications #-} 2 | module Curry.LanguageServer.CPM.Deps 3 | ( generatePathsJsonWithCPM 4 | , readPathsJson 5 | ) where 6 | 7 | import Control.Monad.Error.Class (MonadError (..)) 8 | import Control.Monad.IO.Class (MonadIO (..)) 9 | import Curry.LanguageServer.CPM.Monad (CPMM) 10 | import Curry.LanguageServer.CPM.Process (invokeCPM) 11 | import Control.Exception (try, IOException) 12 | import Control.Monad (void, join) 13 | import Data.Aeson (decodeFileStrict) 14 | import Data.Either.Combinators (rightToMaybe) 15 | import System.FilePath (()) 16 | 17 | -- | Tries generating the '.curry/language-server/paths.json' from a CPM package's dependencies. 18 | generatePathsJsonWithCPM :: FilePath -> FilePath -> CPMM () 19 | generatePathsJsonWithCPM dirPath = void . invokeCPM dirPath ["deps", "--language-server"] 20 | 21 | -- | Reads the '.curry/language-server/paths.json'. 22 | readPathsJson :: FilePath -> CPMM [FilePath] 23 | readPathsJson dirPath = do 24 | let pathsJsonPath = dirPath ".curry" "language-server" "paths.json" 25 | result <- liftIO . (join . rightToMaybe <$>) . try @IOException $ decodeFileStrict pathsJsonPath 26 | case result of 27 | Just paths -> return paths 28 | Nothing -> throwError $ "Could not read or decode " <> pathsJsonPath <> "!" 29 | -------------------------------------------------------------------------------- /src/Curry/LanguageServer/CPM/Monad.hs: -------------------------------------------------------------------------------- 1 | module Curry.LanguageServer.CPM.Monad (CPMM, cpmm, runCPMM) where 2 | 3 | import Control.Monad.IO.Class (MonadIO (..)) 4 | import Control.Monad.Trans.Except (ExceptT(..), runExceptT) 5 | 6 | -- | The monad for running the Curry Package Manager process. 7 | type CPMM = ExceptT String IO 8 | 9 | -- | Runs the monad used for running Curry Package Manager actions. 10 | runCPMM :: MonadIO m => CPMM a -> m (Either String a) 11 | runCPMM = liftIO . runExceptT 12 | 13 | -- | Constructs the monad used for running the Curry Package Manager actions. 14 | cpmm :: IO (Either String a) -> CPMM a 15 | cpmm = ExceptT 16 | -------------------------------------------------------------------------------- /src/Curry/LanguageServer/CPM/Process.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NumericUnderscores #-} 2 | 3 | module Curry.LanguageServer.CPM.Process 4 | ( invokeCPM 5 | ) where 6 | 7 | import Control.Monad (when) 8 | import Control.Monad.Error.Class (MonadError(..)) 9 | import Curry.LanguageServer.CPM.Monad (cpmm, CPMM) 10 | import Curry.LanguageServer.Utils.General (replaceString) 11 | import Data.Either.Extra (maybeToEither) 12 | import System.Exit (ExitCode (..)) 13 | import System.Process (readCreateProcessWithExitCode, shell, CreateProcess(cwd)) 14 | import System.Timeout (timeout) 15 | 16 | -- | Invokes the Curry Package Manager executable with the specified args. 17 | invokeCPM :: FilePath -> [String] -> FilePath -> CPMM String 18 | invokeCPM dir args cpmPath = do 19 | let action = readCreateProcessWithExitCode procOpts "" 20 | 21 | (exitCode, out, err) <- cpmm $ maybeToEither "CPM timed out!" <$> timeout microsecs action 22 | when (exitCode /= ExitSuccess) $ throwError $ errMessage err 23 | 24 | return out 25 | where errMessage e = "Please make sure that '" <> cpmPath <> "' exists or is on your PATH! Error: " ++ replaceString "\n" " " (show e) 26 | procOpts = (shell $ unwords $ cpmPath : args) { cwd = Just dir } 27 | microsecs = 20_000_000 28 | -------------------------------------------------------------------------------- /src/Curry/LanguageServer/Compiler.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase, NoFieldSelectors, OverloadedStrings, OverloadedRecordDot, FlexibleContexts #-} 2 | module Curry.LanguageServer.Compiler 3 | ( CompileAuxiliary (..) 4 | , CompileState (..) 5 | , CompileOutput 6 | , FileLoader 7 | , compileCurryFileWithDeps 8 | , failedCompilation 9 | ) where 10 | 11 | -- Curry Compiler Libraries + Dependencies 12 | import qualified Curry.Files.Filenames as CFN 13 | import qualified Curry.Files.PathUtils as CF 14 | import qualified Curry.Files.Unlit as CUL 15 | import qualified Curry.Base.Ident as CI 16 | import qualified Curry.Base.Span as CSP 17 | import qualified Curry.Base.SpanInfo as CSPI 18 | import qualified Curry.Base.Message as CM 19 | import Curry.Base.Monad (CYIO, CYT, runCYIO, liftCYM, silent, failMessages, warnMessages) 20 | import qualified Curry.Syntax as CS 21 | import qualified Curry.Syntax.Extension as CSE 22 | import qualified Curry.Frontend.Base.Messages as CBM 23 | import qualified Curry.Frontend.Checks as CC 24 | import qualified Curry.Frontend.CurryBuilder as CB 25 | import qualified Curry.Frontend.CurryDeps as CD 26 | import qualified Curry.Frontend.CompilerEnv as CE 27 | import qualified Curry.Frontend.CondCompile as CNC 28 | import qualified Curry.Frontend.CompilerOpts as CO 29 | import qualified Curry.Frontend.Env.Interface as CEI 30 | import qualified Curry.Frontend.Exports as CEX 31 | import qualified Curry.Frontend.Imports as CIM 32 | import qualified Curry.Frontend.Interfaces as CIF 33 | import qualified Curry.Frontend.Modules as CMD 34 | import qualified Curry.Frontend.Transformations as CT 35 | import qualified Text.PrettyPrint as PP 36 | 37 | import Control.Exception (evaluate) 38 | import Control.Monad (join, when) 39 | import Control.Monad.Trans (lift) 40 | import Control.Monad.Trans.Reader (ReaderT (..)) 41 | import Control.Monad.Trans.State (StateT (..)) 42 | import Control.Monad.Trans.Maybe (MaybeT (..)) 43 | import Control.Monad.IO.Class (MonadIO (..)) 44 | import Control.Monad.Reader.Class (asks) 45 | import Control.Monad.State.Class (modify, gets) 46 | import qualified Curry.LanguageServer.Config as CFG 47 | import Curry.LanguageServer.Utils.Convert (ppToText) 48 | import Curry.LanguageServer.Utils.General ((<.$>)) 49 | import Curry.LanguageServer.Utils.Logging (debugM) 50 | import Curry.LanguageServer.Utils.Sema (ModuleAST) 51 | import Data.List (nub) 52 | import qualified Data.Map as M 53 | import Data.Maybe (fromMaybe) 54 | import qualified Data.Text as T 55 | import Language.LSP.Server (MonadLsp) 56 | import System.FilePath ((), takeFileName) 57 | 58 | type FileLoader = FilePath -> IO String 59 | 60 | -- | Read-only state used during compilation. 61 | newtype CompileAuxiliary = CompileAuxiliary 62 | { fileLoader :: FileLoader 63 | } 64 | 65 | -- | Read/write state used during compilation. 66 | data CompileState = CompileState 67 | { warnings :: [CM.Message] 68 | , errors :: [CM.Message] 69 | } 70 | 71 | instance Semigroup CompileState where 72 | x <> y = CompileState 73 | { warnings = x.warnings ++ y.warnings 74 | , errors = x.errors ++ y.errors 75 | } 76 | 77 | instance Monoid CompileState where 78 | mempty = CompileState 79 | { warnings = [] 80 | , errors = [] 81 | } 82 | 83 | -- | A custom monad for compilation state as a CYIO-replacement that doesn't track errors in an ExceptT. 84 | type CMT m = MaybeT (StateT CompileState (ReaderT CompileAuxiliary m)) 85 | 86 | runCMT :: MonadIO m => CMT m a -> CompileAuxiliary -> m (Maybe a, CompileState) 87 | runCMT cm aux = flip runReaderT aux . flip runStateT mempty . runMaybeT $ cm 88 | 89 | catchCYIO :: MonadIO m => CYIO a -> CMT m (Maybe a) 90 | catchCYIO cyio = liftIO (runCYIO cyio) >>= \(ei, ws) -> do 91 | ws' <- mapM (liftIO . evaluate) ws 92 | modify $ \s -> s { warnings = s.warnings ++ ws' } 93 | case ei of 94 | Left es -> do 95 | es' <- mapM (liftIO . evaluate) es 96 | modify $ \s -> s { errors = s.errors ++ es' } 97 | return Nothing 98 | Right x -> do 99 | return $ Just x 100 | 101 | liftToCM :: Monad m => m a -> CMT m a 102 | liftToCM = lift . lift . lift 103 | 104 | liftCYIO :: MonadIO m => CYIO a -> CMT m a 105 | liftCYIO = MaybeT . (join <$>) . runMaybeT . catchCYIO 106 | 107 | type CompileOutput = [(FilePath, CE.CompEnv ModuleAST)] 108 | 109 | -- | Compiles a Curry source file with its dependencies 110 | -- using the given import paths and the given output directory 111 | -- (in which the interface file will be placed). If compilation fails the 112 | -- result will be `Left` and contain error messages. 113 | -- Otherwise it will be `Right` and contain both the parsed AST and 114 | -- warning messages. 115 | compileCurryFileWithDeps :: (MonadIO m, MonadLsp CFG.Config m) => CFG.Config -> CompileAuxiliary -> [FilePath] -> FilePath -> FilePath -> m (CompileOutput, CompileState) 116 | compileCurryFileWithDeps cfg aux importPaths outDirPath filePath = (fromMaybe mempty <.$>) $ flip runCMT aux $ do 117 | let defOpts = CO.defaultOptions 118 | cppOpts = CO.optCppOpts defOpts 119 | cppDefs = M.insert "__PAKCS__" 300 (CO.cppDefinitions cppOpts) 120 | opts = CO.defaultOptions { CO.optForce = cfg.forceRecompilation 121 | , CO.optImportPaths = importPaths ++ cfg.importPaths 122 | , CO.optLibraryPaths = cfg.libraryPaths 123 | , CO.optCppOpts = cppOpts { CO.cppDefinitions = cppDefs } 124 | , CO.optExtensions = nub $ CSE.kielExtensions ++ CO.optExtensions defOpts 125 | , CO.optOriginPragmas = True 126 | } 127 | -- Resolve dependencies 128 | deps <- liftCYIO $ CD.flatDeps opts filePath 129 | liftToCM $ debugM $ "Compiling " <> T.pack (takeFileName filePath) <> ", found deps: " <> T.intercalate ", " (ppToText . fst <$> deps) 130 | -- Compile the module and its dependencies in topological order 131 | compileCurryModules opts outDirPath deps 132 | 133 | -- | Compiles the given list of modules in order. 134 | compileCurryModules :: (MonadIO m, MonadLsp CFG.Config m) => CO.Options -> FilePath -> [(CI.ModuleIdent, CD.Source)] -> CMT m CompileOutput 135 | compileCurryModules opts outDirPath deps = case deps of 136 | [] -> liftCYIO $ failMessages [makeFailMessage "Language Server: No module found"] 137 | ((m, CD.Source fp ps _is):ds) -> do 138 | liftToCM $ debugM $ "Actually compiling " <> T.pack fp 139 | opts' <- liftCYIO $ CB.processPragmas opts ps 140 | output <- compileCurryModule opts' outDirPath m fp 141 | if null ds 142 | then return output 143 | else (output <>) <$> compileCurryModules opts outDirPath ds 144 | (_:ds) -> compileCurryModules opts outDirPath ds 145 | 146 | -- | Compiles a single module. 147 | compileCurryModule :: (MonadIO m, MonadLsp CFG.Config m) => CO.Options -> FilePath -> CI.ModuleIdent -> FilePath -> CMT m CompileOutput 148 | compileCurryModule opts outDirPath m fp = do 149 | liftToCM $ debugM $ "Compiling module " <> T.pack (takeFileName fp) 150 | -- Parse and check the module 151 | mdl <- loadAndCheckCurryModule opts m fp 152 | errs <- gets (.errors) 153 | when (null errs) $ do 154 | -- Generate and store an on-disk interface file 155 | mdl' <- CC.expandExports opts mdl 156 | interf <- liftCYIO $ uncurry (CEX.exportInterface opts) $ CT.qual mdl' 157 | let interfFilePath = outDirPath CFN.interfName (CFN.moduleNameToFile m) 158 | generated = PP.render $ CS.pPrint interf 159 | liftToCM $ debugM $ "Writing interface file to " <> T.pack interfFilePath 160 | liftIO $ CF.writeModule interfFilePath generated 161 | return [(fp, mdl)] 162 | 163 | -- The following functions partially reimplement 164 | -- https://git.ps.informatik.uni-kiel.de/curry/curry-frontend/-/blob/master/src/Modules.hs 165 | -- since the original module loader/parser does not support virtualized file systems. 166 | -- License : BSD-3-clause 167 | -- Copyright : (c) 1999 - 2004 Wolfgang Lux 168 | -- 2005 Martin Engelke 169 | -- 2007 Sebastian Fischer 170 | -- 2011 - 2015 Björn Peemöller 171 | -- 2016 Jan Tikovsky 172 | -- 2016 - 2017 Finn Teegen 173 | -- 2018 Kai-Oliver Prott 174 | 175 | -- | Loads a single module and performs checks. 176 | loadAndCheckCurryModule :: (MonadIO m, MonadLsp CFG.Config m) => CO.Options -> CI.ModuleIdent -> FilePath -> CMT m (CE.CompEnv ModuleAST) 177 | loadAndCheckCurryModule opts m fp = do 178 | -- Read source file (possibly from VFS) 179 | fl <- asks (.fileLoader) 180 | src <- liftIO $ fl fp 181 | -- Load and check module 182 | loaded <- liftCYIO $ loadCurryModule opts m src fp 183 | checked <- catchCYIO $ CMD.checkModule opts loaded 184 | liftCYIO $ warnMessages $ maybe [] (uncurry (CC.warnCheck opts)) checked 185 | let ast = maybe (Nothing <$ snd loaded) ((Just <$>) . snd) checked 186 | env = maybe (fst loaded) fst checked 187 | return (env, ast) 188 | 189 | -- | Loads a single module. 190 | loadCurryModule :: CO.Options -> CI.ModuleIdent -> String -> FilePath -> CYIO (CE.CompEnv (CS.Module())) 191 | loadCurryModule opts m src fp = do 192 | -- Parse the module 193 | (lexed, ast) <- parseCurryModule opts m src fp 194 | -- Load the imported interfaces into an InterfaceEnv 195 | let paths = CFN.addOutDir (CO.optUseOutDir opts) (CO.optOutDir opts) <$> ("." : CO.optImportPaths opts) 196 | let withPrelude = importCurryPrelude opts ast 197 | iEnv <- CIF.loadInterfaces paths withPrelude 198 | checkInterfaces opts iEnv 199 | is <- importSyntaxCheck iEnv withPrelude 200 | -- Add Information of imported modules 201 | cEnv <- CIM.importModules withPrelude iEnv is 202 | return (cEnv { CE.filePath = fp, CE.tokens = lexed }, ast) 203 | 204 | -- | Checks all interfaces. 205 | checkInterfaces :: Monad m => CO.Options -> CEI.InterfaceEnv -> CYT m () 206 | checkInterfaces opts iEnv = mapM_ checkInterface $ M.elems iEnv 207 | where checkInterface intf = do 208 | let env = CIM.importInterfaces intf iEnv 209 | CC.interfaceCheck opts (env, intf) 210 | 211 | -- | Checks all imports in the module. 212 | importSyntaxCheck :: Monad m => CEI.InterfaceEnv -> CS.Module a -> CYT m [CS.ImportDecl] 213 | importSyntaxCheck iEnv (CS.Module _ _ _ _ _ is _) = mapM checkImportDecl is 214 | where checkImportDecl (CS.ImportDecl p m q asM is') = case M.lookup m iEnv of 215 | Just intf -> CS.ImportDecl p m q asM `fmap` CC.importCheck intf is' 216 | Nothing -> CBM.internalError $ "compiler: No interface for " ++ show m 217 | 218 | -- | Ensures that a Prelude is present in the module. 219 | importCurryPrelude :: CO.Options -> CS.Module () -> CS.Module () 220 | importCurryPrelude opts m@(CS.Module spi li ps mid es is ds) | needed = CS.Module spi li ps mid es (preludeImpl : is) ds 221 | | otherwise = m 222 | where isPrelude = mid == CI.preludeMIdent 223 | disabled = CS.NoImplicitPrelude `elem` CO.optExtensions opts || m `CS.hasLanguageExtension` CS.NoImplicitPrelude 224 | imported = CI.preludeMIdent `elem` ((\(CS.ImportDecl _ i _ _ _) -> i) <$> is) 225 | needed = not isPrelude && not disabled && not imported 226 | preludeImpl = CS.ImportDecl CSPI.NoSpanInfo CI.preludeMIdent False Nothing Nothing 227 | 228 | -- | Parses a single module. 229 | parseCurryModule :: CO.Options -> CI.ModuleIdent -> String -> FilePath -> CYIO ([(CSP.Span, CS.Token)], CS.Module ()) 230 | parseCurryModule opts _ src fp = do 231 | ul <- liftCYM $ CUL.unlit fp src 232 | -- TODO: Preprocess 233 | cc <- CNC.condCompile (CO.optCppOpts opts) fp ul 234 | lexed <- liftCYM $ silent $ CS.lexSource fp cc 235 | ast <- liftCYM $ CS.parseModule fp cc 236 | -- TODO: Check module/file mismatch? 237 | return (lexed, ast) 238 | 239 | failedCompilation :: String -> (CompileOutput, CompileState) 240 | failedCompilation msg = (mempty, mempty { errors = [makeFailMessage msg] }) 241 | 242 | makeFailMessage :: String -> CM.Message 243 | makeFailMessage = CM.message . PP.text 244 | -------------------------------------------------------------------------------- /src/Curry/LanguageServer/Config.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoFieldSelectors, OverloadedRecordDot, RecordWildCards, OverloadedStrings, TypeApplications #-} 2 | module Curry.LanguageServer.Config 3 | ( Config (..) 4 | , LogLevel (..) 5 | ) where 6 | 7 | import Colog.Core (Severity (..)) 8 | import Curry.LanguageServer.Extension (Extension (..)) 9 | import Data.Aeson 10 | ( FromJSON (..) 11 | , ToJSON (..) 12 | , (.!=) 13 | , (.:?) 14 | , withObject 15 | , object 16 | , KeyValue (..) 17 | ) 18 | import Data.Default (Default(..)) 19 | import qualified Data.Text as T 20 | 21 | newtype LogLevel = LogLevel { severity :: Severity } 22 | deriving (Show, Eq) 23 | 24 | data Config = Config { forceRecompilation :: Bool 25 | , importPaths :: [FilePath] 26 | , libraryPaths :: [FilePath] 27 | , logLevel :: LogLevel 28 | , curryPath :: String 29 | , useSnippetCompletions :: Bool 30 | , extensions :: [Extension] 31 | } 32 | deriving (Show, Eq) 33 | 34 | instance Default Config where 35 | def = Config { forceRecompilation = False 36 | , importPaths = [] 37 | , libraryPaths = [] 38 | , logLevel = LogLevel Info 39 | , curryPath = "pakcs" 40 | , useSnippetCompletions = False 41 | , extensions = [] 42 | } 43 | 44 | instance FromJSON Config where 45 | parseJSON = withObject "Config" $ \l -> do 46 | forceRecompilation <- l .:? "forceRecompilation" .!= (def @Config).forceRecompilation 47 | importPaths <- l .:? "importPaths" .!= (def @Config).importPaths 48 | libraryPaths <- l .:? "libraryPaths" .!= (def @Config).libraryPaths 49 | logLevel <- l .:? "logLevel" .!= (def @Config).logLevel 50 | curryPath <- l .:? "curryPath" .!= (def @Config).curryPath 51 | useSnippetCompletions <- l .:? "useSnippetCompletions" .!= (def @Config).useSnippetCompletions 52 | extensions <- l .:? "extensions" .!= (def @Config).extensions 53 | return Config {..} 54 | 55 | instance ToJSON Config where 56 | toJSON Config {..} = object 57 | [ "forceRecompilation" .= forceRecompilation 58 | , "importPaths" .= importPaths 59 | , "libraryPaths" .= libraryPaths 60 | , "logLevel" .= logLevel 61 | , "curryPath" .= curryPath 62 | , "useSnippetCompletions" .= useSnippetCompletions 63 | , "extensions" .= extensions 64 | ] 65 | 66 | instance FromJSON LogLevel where 67 | parseJSON v = do 68 | s <- parseJSON v 69 | return $ case s :: T.Text of 70 | "debug" -> LogLevel Debug 71 | "info" -> LogLevel Info 72 | "warning" -> LogLevel Warning 73 | "error" -> LogLevel Error 74 | _ -> undefined 75 | 76 | instance ToJSON LogLevel where 77 | toJSON (LogLevel sev) = toJSON @T.Text $ case sev of 78 | Debug -> "debug" 79 | Info -> "info" 80 | Warning -> "warning" 81 | Error -> "error" 82 | -------------------------------------------------------------------------------- /src/Curry/LanguageServer/Extension.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedRecordDot, OverloadedStrings, RecordWildCards, TypeApplications #-} 2 | module Curry.LanguageServer.Extension 3 | ( ExtensionPoint (..), ExtensionOutputFormat (..), Extension (..) 4 | ) where 5 | 6 | import Data.Aeson (FromJSON (..), ToJSON (..), (.:?), (.!=), (.=), object, withObject) 7 | import Data.Default (Default (..)) 8 | import qualified Data.Text as T 9 | 10 | data ExtensionPoint = ExtensionPointHover 11 | | ExtensionPointUnknown T.Text 12 | deriving (Show, Eq) 13 | 14 | data ExtensionOutputFormat = ExtensionOutputFormatPlaintext 15 | | ExtensionOutputFormatMarkdown 16 | | ExtensionOutputFormatUnknown T.Text 17 | deriving (Show, Eq) 18 | 19 | data Extension = Extension 20 | { name :: T.Text 21 | , extensionPoint :: ExtensionPoint 22 | , outputFormat :: ExtensionOutputFormat 23 | , showOutputOnError :: Bool 24 | , executable :: T.Text 25 | , args :: [T.Text] 26 | } 27 | deriving (Show, Eq) 28 | 29 | instance Default Extension where 30 | def = Extension 31 | { name = "Anonymous Extension" 32 | , extensionPoint = ExtensionPointHover 33 | , outputFormat = ExtensionOutputFormatPlaintext 34 | , showOutputOnError = False 35 | , executable = "echo" 36 | , args = [] 37 | } 38 | 39 | instance FromJSON Extension where 40 | parseJSON = withObject "Extension" $ \e -> do 41 | name <- e .:? "name" .!= (def @Extension).name 42 | extensionPoint <- e .:? "extensionPoint" .!= (def @Extension).extensionPoint 43 | outputFormat <- e .:? "outputFormat" .!= (def @Extension).outputFormat 44 | showOutputOnError <- e .:? "showOutputOnError" .!= (def @Extension).showOutputOnError 45 | executable <- e .:? "executable" .!= (def @Extension).executable 46 | args <- e .:? "args" .!= (def @Extension).args 47 | return Extension {..} 48 | 49 | instance ToJSON Extension where 50 | toJSON Extension {..} = object 51 | [ "name" .= name 52 | , "extensionPoint" .= extensionPoint 53 | , "outputFormat" .= outputFormat 54 | , "showOutputOnError" .= showOutputOnError 55 | , "executable" .= executable 56 | , "args" .= args 57 | ] 58 | 59 | instance FromJSON ExtensionPoint where 60 | parseJSON v = do 61 | s <- parseJSON v 62 | return $ case s :: T.Text of 63 | "hover" -> ExtensionPointHover 64 | _ -> ExtensionPointUnknown s 65 | 66 | instance ToJSON ExtensionPoint where 67 | toJSON p = toJSON @T.Text $ case p of 68 | ExtensionPointHover -> "hover" 69 | ExtensionPointUnknown s -> s 70 | 71 | instance FromJSON ExtensionOutputFormat where 72 | parseJSON v = do 73 | s <- parseJSON v 74 | return $ case s :: T.Text of 75 | "plaintext" -> ExtensionOutputFormatPlaintext 76 | "markdown" -> ExtensionOutputFormatMarkdown 77 | _ -> ExtensionOutputFormatUnknown s 78 | 79 | instance ToJSON ExtensionOutputFormat where 80 | toJSON p = toJSON @T.Text $ case p of 81 | ExtensionOutputFormatPlaintext -> "plaintext" 82 | ExtensionOutputFormatMarkdown -> "markdown" 83 | ExtensionOutputFormatUnknown s -> s 84 | -------------------------------------------------------------------------------- /src/Curry/LanguageServer/FileLoader.hs: -------------------------------------------------------------------------------- 1 | module Curry.LanguageServer.FileLoader (fileLoader) where 2 | 3 | import Control.Monad.IO.Unlift (askRunInIO) 4 | import qualified Curry.LanguageServer.Compiler as C 5 | import Curry.LanguageServer.Monad (LSM) 6 | import Curry.LanguageServer.Utils.Uri (filePathToNormalizedUri) 7 | import qualified Data.Text as T 8 | import qualified Language.LSP.Server as S 9 | import qualified Language.LSP.VFS as VFS 10 | 11 | fileLoader :: LSM C.FileLoader 12 | fileLoader = do 13 | runInIO <- askRunInIO 14 | return $ \fp -> do 15 | normUri <- filePathToNormalizedUri fp 16 | vfile <- runInIO $ S.getVirtualFile normUri 17 | 18 | case T.unpack . VFS.virtualFileText <$> vfile of 19 | Just vfsContent -> return vfsContent 20 | Nothing -> readFile fp 21 | -------------------------------------------------------------------------------- /src/Curry/LanguageServer/Handlers.hs: -------------------------------------------------------------------------------- 1 | module Curry.LanguageServer.Handlers (handlers) where 2 | 3 | import Curry.LanguageServer.Handlers.Cancel (cancelHandler) 4 | import Curry.LanguageServer.Handlers.Initialize (initializedHandler) 5 | import Curry.LanguageServer.Handlers.TextDocument.CodeAction (codeActionHandler) 6 | import Curry.LanguageServer.Handlers.TextDocument.CodeLens (codeLensHandler) 7 | import Curry.LanguageServer.Handlers.TextDocument.Completion (completionHandler) 8 | import Curry.LanguageServer.Handlers.TextDocument.Definition (definitionHandler) 9 | import Curry.LanguageServer.Handlers.TextDocument.DocumentSymbol (documentSymbolHandler) 10 | import Curry.LanguageServer.Handlers.TextDocument.Notifications (didOpenHandler, didChangeHandler, didSaveHandler, didCloseHandler) 11 | import Curry.LanguageServer.Handlers.TextDocument.Hover (hoverHandler) 12 | import Curry.LanguageServer.Handlers.TextDocument.References (referencesHandler) 13 | import Curry.LanguageServer.Handlers.TextDocument.SignatureHelp (signatureHelpHandler) 14 | import Curry.LanguageServer.Handlers.Workspace.Command (executeCommandHandler) 15 | import Curry.LanguageServer.Handlers.Workspace.Symbol (workspaceSymbolHandler) 16 | import Curry.LanguageServer.Monad (LSM) 17 | import qualified Language.LSP.Protocol.Types as J 18 | import qualified Language.LSP.Server as S 19 | 20 | handlers :: J.ClientCapabilities -> S.Handlers LSM 21 | handlers _caps = mconcat 22 | [ -- Request handlers 23 | completionHandler 24 | , executeCommandHandler 25 | , definitionHandler 26 | , documentSymbolHandler 27 | , hoverHandler 28 | , workspaceSymbolHandler 29 | , codeActionHandler 30 | , codeLensHandler 31 | , referencesHandler 32 | , signatureHelpHandler 33 | -- Notification handlers 34 | , initializedHandler 35 | , didOpenHandler 36 | , didChangeHandler 37 | , didSaveHandler 38 | , didCloseHandler 39 | , cancelHandler 40 | ] 41 | -------------------------------------------------------------------------------- /src/Curry/LanguageServer/Handlers/Cancel.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module Curry.LanguageServer.Handlers.Cancel 3 | ( cancelHandler 4 | ) where 5 | 6 | import Curry.LanguageServer.Monad (LSM) 7 | import Curry.LanguageServer.Utils.Logging (debugM) 8 | import qualified Language.LSP.Server as S 9 | import qualified Language.LSP.Protocol.Message as J 10 | 11 | cancelHandler :: S.Handlers LSM 12 | cancelHandler = S.notificationHandler J.SMethod_CancelRequest $ \_nt -> do 13 | debugM "Processing cancel request" 14 | -- TODO: This is currently just a stub to prevent error messages 15 | -- about the unimplemented request from showing up, we might 16 | -- want to implement actual cancellation (though most things 17 | -- are handled synchronously currently, so it shouldn't really 18 | -- be needed yet) 19 | 20 | -------------------------------------------------------------------------------- /src/Curry/LanguageServer/Handlers/Config.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module Curry.LanguageServer.Handlers.Config 3 | ( onConfigChange 4 | ) where 5 | 6 | import Curry.LanguageServer.Config (Config (..)) 7 | import Curry.LanguageServer.Monad (LSM) 8 | import Curry.LanguageServer.Utils.Logging (infoM) 9 | 10 | onConfigChange :: Config -> LSM () 11 | onConfigChange _cfg = do 12 | infoM "Changed configuration" 13 | -------------------------------------------------------------------------------- /src/Curry/LanguageServer/Handlers/Diagnostics.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts, OverloadedStrings, OverloadedRecordDot #-} 2 | module Curry.LanguageServer.Handlers.Diagnostics (emitDiagnostics, fetchDiagnostics) where 3 | 4 | import Control.Monad (unless) 5 | import Control.Monad.IO.Class (MonadIO (..)) 6 | import qualified Curry.LanguageServer.Config as CFG 7 | import Curry.LanguageServer.Index.Store (ModuleStoreEntry (..)) 8 | import Curry.LanguageServer.Utils.Convert (curryMsg2Diagnostic) 9 | import Curry.LanguageServer.Utils.Uri (normalizedUriToFilePath) 10 | import Curry.LanguageServer.Utils.Logging (infoM) 11 | import Curry.LanguageServer.Monad (LSM) 12 | import qualified Data.Map as M 13 | import qualified Data.SortedList as SL 14 | import qualified Data.Text as T 15 | import qualified Language.LSP.Diagnostics as D 16 | import qualified Language.LSP.Server as S 17 | import Language.LSP.Server (MonadLsp) 18 | import qualified Language.LSP.Protocol.Types as J 19 | import System.FilePath (takeBaseName) 20 | 21 | emitDiagnostics :: J.NormalizedUri -> ModuleStoreEntry -> LSM () 22 | emitDiagnostics normUri entry = do 23 | diags <- fetchDiagnostics normUri entry 24 | let -- Workaround for empty diagnostics: https://github.com/haskell/lsp/issues/139 25 | diagsBySrc | null diags = M.singleton Nothing (SL.toSortedList []) 26 | | otherwise = D.partitionBySource diags 27 | maxDiags = 500 28 | version = Just 0 29 | S.publishDiagnostics maxDiags normUri version diagsBySrc 30 | 31 | fetchDiagnostics :: (MonadIO m, MonadLsp CFG.Config m) => J.NormalizedUri -> ModuleStoreEntry -> m [J.Diagnostic] 32 | fetchDiagnostics normUri entry = do 33 | let warnings = map (curryMsg2Diagnostic J.DiagnosticSeverity_Warning) entry.warningMessages 34 | errors = map (curryMsg2Diagnostic J.DiagnosticSeverity_Error) entry.errorMessages 35 | diags = warnings ++ errors 36 | name = maybe "?" takeBaseName $ normalizedUriToFilePath normUri 37 | 38 | unless (null diags) $ 39 | infoM $ "Found " <> T.pack (show (length diags)) <> " message(s) in " <> T.pack name 40 | 41 | return diags 42 | -------------------------------------------------------------------------------- /src/Curry/LanguageServer/Handlers/Initialize.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds, OverloadedStrings #-} 2 | module Curry.LanguageServer.Handlers.Initialize (initializeHandler, initializedHandler) where 3 | 4 | import Control.Lens ((^.)) 5 | import Curry.LanguageServer.FileLoader (fileLoader) 6 | import Curry.LanguageServer.Handlers.Diagnostics (emitDiagnostics) 7 | import Curry.LanguageServer.Utils.Logging (infoM) 8 | import qualified Curry.LanguageServer.Index.Store as I 9 | import Curry.LanguageServer.Monad (LSM) 10 | import Data.Maybe (maybeToList, fromMaybe) 11 | import qualified Data.Text as T 12 | import qualified Language.LSP.Protocol.Lens as J 13 | import qualified Language.LSP.Protocol.Types as J 14 | import qualified Language.LSP.Protocol.Message as J 15 | import qualified Language.LSP.Server as S 16 | 17 | initializeHandler :: J.TMessage J.Method_Initialize -> LSM () 18 | initializeHandler req = do 19 | let token = req ^. J.params . J.workDoneToken 20 | S.withIndefiniteProgress "Initializing Curry..." token S.NotCancellable $ \_updater -> do 21 | infoM "Building index store..." 22 | workspaceFolders <- fromMaybe [] <$> S.getWorkspaceFolders 23 | let folderToPath (J.WorkspaceFolder uri _) = J.uriToFilePath uri 24 | folders = maybeToList . folderToPath =<< workspaceFolders 25 | mapM_ addDirToIndexStore folders 26 | count <- I.getModuleCount 27 | infoM $ "Indexed " <> T.pack (show count) <> " files" 28 | 29 | initializedHandler :: S.Handlers LSM 30 | initializedHandler = S.notificationHandler J.SMethod_Initialized $ \_nt -> do 31 | entries <- I.getModuleList 32 | mapM_ (uncurry emitDiagnostics) entries 33 | 34 | -- | Indexes a workspace folder recursively. 35 | addDirToIndexStore :: FilePath -> LSM () 36 | addDirToIndexStore dirPath = do 37 | fl <- fileLoader 38 | cfg <- S.getConfig 39 | I.addWorkspaceDir cfg fl dirPath 40 | -------------------------------------------------------------------------------- /src/Curry/LanguageServer/Handlers/TextDocument/CodeAction.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts, FlexibleInstances, OverloadedStrings, OverloadedRecordDot #-} 2 | module Curry.LanguageServer.Handlers.TextDocument.CodeAction (codeActionHandler) where 3 | 4 | -- Curry Compiler Libraries + Dependencies 5 | import qualified Curry.Base.Message as CM 6 | 7 | import Control.Lens ((^.)) 8 | import Control.Monad.Extra (mapMaybeM) 9 | import Control.Monad.IO.Class (MonadIO (..)) 10 | import Control.Monad.Trans (lift) 11 | import Control.Monad.Trans.Maybe (runMaybeT) 12 | import qualified Curry.LanguageServer.Config as CFG 13 | import qualified Curry.LanguageServer.Index.Store as I 14 | import Curry.LanguageServer.Monad (LSM) 15 | import Curry.LanguageServer.Utils.Convert (curryQuickFix2CodeAction, curryMsg2Diagnostic) 16 | import Curry.LanguageServer.Utils.General (rangeOverlaps) 17 | import Curry.LanguageServer.Utils.Logging (debugM) 18 | import Curry.LanguageServer.Utils.Uri (normalizeUriWithPath) 19 | import Data.Maybe (fromMaybe) 20 | import qualified Language.LSP.Server as S 21 | import Language.LSP.Server (MonadLsp) 22 | import qualified Language.LSP.Protocol.Types as J 23 | import qualified Language.LSP.Protocol.Lens as J 24 | import qualified Language.LSP.Protocol.Message as J 25 | 26 | codeActionHandler :: S.Handlers LSM 27 | codeActionHandler = S.requestHandler J.SMethod_TextDocumentCodeAction $ \req responder -> do 28 | debugM "Processing code action request" 29 | let J.CodeActionParams _ _ doc range _ = req ^. J.params 30 | uri = doc ^. J.uri 31 | normUri <- normalizeUriWithPath uri 32 | actions <- runMaybeT $ do 33 | entry <- I.getModule normUri 34 | lift $ fetchCodeActionsInRange range entry 35 | responder $ Right $ J.InL $ J.InR <$> fromMaybe [] actions 36 | 37 | fetchCodeActionsInRange :: (MonadIO m, MonadLsp CFG.Config m) => J.Range -> I.ModuleStoreEntry -> m [J.CodeAction] 38 | fetchCodeActionsInRange range entry = filterCodeActionsInRange range <$> fetchCodeActions entry 39 | 40 | filterCodeActionsInRange :: J.Range -> [J.CodeAction] -> [J.CodeAction] 41 | filterCodeActionsInRange range = filter $ \a -> 42 | let editRanges = [ txtEdit ^. J.range 43 | | Just workspaceEdit <- [a ^. J.edit] 44 | , Just changes <- [workspaceEdit ^. J.documentChanges] 45 | , J.InL docEdit <- changes 46 | , J.InL txtEdit <- docEdit ^. J.edits 47 | ] 48 | diagRanges = [ diag ^. J.range 49 | | Just diags <- [a ^. J.diagnostics] 50 | , diag <- diags 51 | ] 52 | ranges = editRanges ++ diagRanges 53 | in any (rangeOverlaps range) ranges 54 | 55 | fetchCodeActions :: (MonadIO m, MonadLsp CFG.Config m) => I.ModuleStoreEntry -> m [J.CodeAction] 56 | fetchCodeActions entry = do 57 | let msgs = entry.warningMessages ++ entry.errorMessages 58 | diags = [curryMsg2Diagnostic s m | (s, ms) <- zip [J.DiagnosticSeverity_Warning, J.DiagnosticSeverity_Error] [entry.warningMessages, entry.errorMessages], m <- ms] 59 | mapMaybeM (runMaybeT . uncurry curryQuickFix2CodeAction) [(f, [diag]) | (diag, m) <- zip diags msgs, f <- CM.msgFixes m] 60 | -------------------------------------------------------------------------------- /src/Curry/LanguageServer/Handlers/TextDocument/CodeLens.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts, FlexibleInstances, OverloadedStrings, OverloadedRecordDot #-} 2 | module Curry.LanguageServer.Handlers.TextDocument.CodeLens (codeLensHandler) where 3 | 4 | -- Curry Compiler Libraries + Dependencies 5 | import qualified Curry.Syntax as CS 6 | import qualified Curry.Frontend.Base.Types as CT 7 | 8 | import Control.Lens ((^.)) 9 | import Control.Monad.IO.Class (MonadIO (..)) 10 | import Control.Monad.Trans (lift) 11 | import Control.Monad.Trans.Maybe (runMaybeT) 12 | import qualified Curry.LanguageServer.Config as CFG 13 | import qualified Curry.LanguageServer.Index.Store as I 14 | import Curry.LanguageServer.Monad (LSM, scheduleModuleHandler) 15 | import Curry.LanguageServer.Utils.Convert (currySpanInfo2Range, currySpanInfo2Uri, ppToText) 16 | import Curry.LanguageServer.Utils.Logging (debugM, infoM) 17 | import Curry.LanguageServer.Utils.Sema (untypedTopLevelDecls) 18 | import Curry.LanguageServer.Utils.Uri (normalizeUriWithPath) 19 | import qualified Data.Aeson as A 20 | import Data.Maybe (fromMaybe, maybeToList) 21 | import qualified Data.Text as T 22 | import qualified Language.LSP.Server as S 23 | import Language.LSP.Server (MonadLsp) 24 | import qualified Language.LSP.Protocol.Types as J 25 | import qualified Language.LSP.Protocol.Lens as J 26 | import qualified Language.LSP.Protocol.Message as J 27 | 28 | codeLensHandler :: S.Handlers LSM 29 | codeLensHandler = S.requestHandler J.SMethod_TextDocumentCodeLens $ \req responder -> do 30 | debugM "Processing code lens request" 31 | let J.CodeLensParams _ _ doc = req ^. J.params 32 | uri = doc ^. J.uri 33 | normUri <- normalizeUriWithPath uri 34 | 35 | debugM $ "Scheduling code lenses for " <> T.pack (show uri) 36 | scheduleModuleHandler uri $ do 37 | lenses <- runMaybeT $ do 38 | entry <- I.getModule normUri 39 | lift $ fetchCodeLenses entry 40 | responder $ Right $ J.InL $ fromMaybe [] lenses 41 | 42 | fetchCodeLenses :: (MonadIO m, MonadLsp CFG.Config m) => I.ModuleStoreEntry -> m [J.CodeLens] 43 | fetchCodeLenses entry = do 44 | lenses <- maybe (pure []) codeLenses entry.moduleAST 45 | infoM $ "Found " <> T.pack (show (length lenses)) <> " code lens(es)" 46 | return lenses 47 | 48 | class HasCodeLenses s where 49 | codeLenses :: MonadIO m => s -> m [J.CodeLens] 50 | 51 | instance HasCodeLenses (CS.Module (Maybe CT.PredType)) where 52 | codeLenses mdl@(CS.Module spi _ _ _ _ _ _) = do 53 | maybeUri <- liftIO $ runMaybeT (currySpanInfo2Uri spi) 54 | 55 | let typeHintLenses = do 56 | (spi', i, tp) <- untypedTopLevelDecls mdl 57 | t <- maybeToList tp 58 | range <- maybeToList $ currySpanInfo2Range spi' 59 | uri <- maybeToList maybeUri 60 | -- TODO: Move the command identifier ('decl.applyTypeHint') to some 61 | -- central place to avoid repetition. 62 | let text = ppToText i <> " :: " <> ppToText t 63 | args = [A.toJSON uri, A.toJSON $ range ^. J.start, A.toJSON text] 64 | command = J.Command text "decl.applyTypeHint" $ Just args 65 | lens = J.CodeLens range (Just command) Nothing 66 | return lens 67 | 68 | return typeHintLenses 69 | -------------------------------------------------------------------------------- /src/Curry/LanguageServer/Handlers/TextDocument/Completion.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoFieldSelectors, OverloadedStrings, OverloadedRecordDot, FlexibleContexts, FlexibleInstances, MultiWayIf #-} 2 | module Curry.LanguageServer.Handlers.TextDocument.Completion (completionHandler) where 3 | 4 | -- Curry Compiler Libraries + Dependencies 5 | import qualified Curry.Syntax as CS 6 | import qualified Curry.Frontend.Base.Types as CT 7 | 8 | import Control.Lens ((^.), (?~)) 9 | import Control.Monad (join, guard) 10 | import Control.Monad.IO.Class (MonadIO) 11 | import Control.Monad.Trans (lift) 12 | import Control.Monad.Trans.Maybe (runMaybeT, MaybeT (..)) 13 | import Control.Monad.State.Class (get) 14 | import qualified Curry.LanguageServer.Config as CFG 15 | import qualified Curry.LanguageServer.Index.Store as I 16 | import qualified Curry.LanguageServer.Index.Symbol as I 17 | import Curry.LanguageServer.Utils.Convert (ppToText, currySpanInfo2Range) 18 | import Curry.LanguageServer.Utils.General (filterF, lastSafe) 19 | import Curry.LanguageServer.Utils.Logging (debugM, infoM) 20 | import Curry.LanguageServer.Utils.Syntax (HasIdentifiers (..)) 21 | import Curry.LanguageServer.Utils.Lookup (findScopeAtPos) 22 | import Curry.LanguageServer.Utils.Uri (normalizeUriWithPath) 23 | import Curry.LanguageServer.Utils.VFS (PosPrefixInfo (..), getCompletionPrefix) 24 | import Curry.LanguageServer.Monad (LSM) 25 | import Data.Bifunctor (Bifunctor (..)) 26 | import Data.List.Extra (nubOrdOn) 27 | import qualified Data.Map as M 28 | import Data.Maybe (maybeToList, fromMaybe, isNothing) 29 | import qualified Data.Set as S 30 | import qualified Data.Text as T 31 | import qualified Language.LSP.Server as S 32 | import qualified Language.LSP.Protocol.Types as J 33 | import qualified Language.LSP.Protocol.Lens as J 34 | import qualified Language.LSP.Protocol.Message as J 35 | import Language.LSP.Server (MonadLsp) 36 | import qualified Curry.Base.Ident as CI 37 | 38 | completionHandler :: S.Handlers LSM 39 | completionHandler = S.requestHandler J.SMethod_TextDocumentCompletion $ \req responder -> do 40 | debugM "Processing completion request" 41 | let uri = req ^. J.params . J.textDocument . J.uri 42 | pos = req ^. J.params . J.position 43 | normUri <- normalizeUriWithPath uri 44 | capabilities <- S.getClientCapabilities 45 | cfg <- S.getConfig 46 | completions <- fmap (join . maybeToList) $ runMaybeT $ do 47 | store <- get 48 | entry <- I.getModule normUri 49 | vfile <- MaybeT $ S.getVirtualFile normUri 50 | 51 | let query = getCompletionPrefix pos vfile 52 | opts = CompletionOptions 53 | { useSnippets = cfg.useSnippetCompletions && fromMaybe False (do 54 | docCapabilities <- capabilities ^. J.textDocument 55 | cmCapabilities <- docCapabilities ^. J.completion 56 | ciCapabilities <- cmCapabilities ^. J.completionItem 57 | ciCapabilities ^. J.snippetSupport) 58 | } 59 | lift $ fetchCompletions opts entry store query 60 | let maxCompletions = 25 61 | items = take maxCompletions completions 62 | incomplete = length completions > maxCompletions 63 | result = J.CompletionList incomplete Nothing items 64 | responder $ Right $ J.InR $ J.InL result 65 | 66 | fetchCompletions :: (MonadIO m, MonadLsp CFG.Config m) => CompletionOptions -> I.ModuleStoreEntry -> I.IndexStore -> PosPrefixInfo -> m [J.CompletionItem] 67 | fetchCompletions opts entry store query 68 | | isPragma = pragmaCompletions opts query 69 | | isImport = importCompletions opts store query 70 | | otherwise = generalCompletions opts entry store query 71 | where line = query.fullLine 72 | isPragma = "{-#" `T.isPrefixOf` line 73 | isImport = "import " `T.isPrefixOf` line 74 | 75 | pragmaCompletions :: MonadIO m => CompletionOptions -> PosPrefixInfo -> m [J.CompletionItem] 76 | pragmaCompletions opts query 77 | | isLanguagePragma = return $ toMatchingCompletions opts query knownExtensions 78 | | isOptionPragma = return [] 79 | | otherwise = return $ toMatchingCompletions opts query pragmaKeywords 80 | where line = query.fullLine 81 | languagePragmaName = "LANGUAGE" 82 | optionPragmaPrefix = "OPTIONS_" 83 | languagePragma = Tagged [] $ Keyword languagePragmaName 84 | knownTools = [minBound..maxBound] :: [CS.KnownTool] 85 | optionPragmas = makeToolOptionKeyword <$> knownTools 86 | makeToolOptionKeyword tool = Tagged tags $ Keyword $ optionPragmaPrefix <> T.pack (show tool) 87 | where tags = case tool of 88 | CS.CYMAKE -> [J.CompletionItemTag_Deprecated] 89 | _ -> [] 90 | isLanguagePragma = languagePragmaName `T.isInfixOf` line 91 | isOptionPragma = optionPragmaPrefix `T.isInfixOf` line 92 | pragmaKeywords = languagePragma : optionPragmas 93 | knownExtensions = Keyword . T.pack . show <$> ([minBound..maxBound] :: [CS.KnownExtension]) 94 | 95 | importCompletions :: (MonadIO m, MonadLsp CFG.Config m) => CompletionOptions -> I.IndexStore -> PosPrefixInfo -> m [J.CompletionItem] 96 | importCompletions opts store query = do 97 | let modules = nubOrdOn (.qualIdent) $ I.storedModuleSymbolsWithPrefix (fullPrefix query) store 98 | moduleCompletions = toMatchingCompletions opts query $ (\s -> CompletionSymbol s Nothing Nothing) <$> modules 99 | keywordCompletions = toMatchingCompletions opts query $ Keyword <$> ["qualified", "as", "hiding"] 100 | completions = moduleCompletions ++ keywordCompletions 101 | infoM $ "Found " <> T.pack (show (length completions)) <> " import completion(s)" 102 | return completions 103 | 104 | generalCompletions :: (MonadIO m, MonadLsp CFG.Config m) => CompletionOptions -> I.ModuleStoreEntry -> I.IndexStore -> PosPrefixInfo -> m [J.CompletionItem] 105 | generalCompletions opts entry store query = do 106 | let localIdentifiers = M.fromList . map (second join . snd) . M.toList $ maybe M.empty (`findScopeAtPos` query.cursorPos) entry.moduleAST 107 | localIdentifiers' = M.mapKeys ppToText (localIdentifiers :: M.Map CI.Ident (Maybe CT.PredType)) 108 | localCompletions = toMatchingCompletions opts query $ uncurry Local <$> M.toList localIdentifiers' 109 | symbols = filter (flip M.notMember localIdentifiers' . (.ident)) $ nubOrdOn (.qualIdent) 110 | $ I.storedSymbolsWithPrefix query.prefixText store 111 | symbolCompletions = toMatchingCompletions opts query $ toCompletionSymbols entry =<< symbols 112 | keywordCompletions = toMatchingCompletions opts query keywords 113 | completions = localCompletions ++ symbolCompletions ++ keywordCompletions 114 | infoM $ "Local identifiers in scope: " <> T.pack (show (M.keys localIdentifiers')) 115 | infoM $ "Found " <> T.pack (show (length completions)) <> " completion(s) with prefix '" <> T.pack (show query.prefixText) <> "'" 116 | return completions 117 | where keywords = Keyword <$> ["case", "class", "data", "default", "deriving", "do", "else", "external", "fcase", "free", "if", "import", "in", "infix", "infixl", "infixr", "instance", "let", "module", "newtype", "of", "then", "type", "where", "as", "ccall", "forall", "hiding", "interface", "primitive", "qualified"] 118 | 119 | toMatchingCompletions :: (ToCompletionItems a, CompletionQueryFilter a, Foldable t) => CompletionOptions -> PosPrefixInfo -> t a -> [J.CompletionItem] 120 | toMatchingCompletions opts query = (toCompletionItems opts query =<<) . filterF (matchesCompletionQuery query) 121 | 122 | newtype Keyword = Keyword T.Text 123 | 124 | data Local = Local T.Text (Maybe CT.PredType) 125 | 126 | data Tagged a = Tagged [J.CompletionItemTag] a 127 | 128 | data CompletionSymbol = CompletionSymbol 129 | { -- The index symbol 130 | symbol :: I.Symbol 131 | -- The, possibly aliased, module name. Nothing means that the symbol is available unqualified. 132 | , moduleName :: Maybe T.Text 133 | -- Import edits to apply after the completion has been selected. Nothing means that the symbol does not require an import. 134 | , importEdits :: Maybe [J.TextEdit] 135 | } 136 | 137 | newtype CompletionOptions = CompletionOptions 138 | { useSnippets :: Bool 139 | } 140 | 141 | -- | Turns an index symbol into completion symbols by analyzing the module's imports. 142 | toCompletionSymbols :: I.ModuleStoreEntry -> I.Symbol -> [CompletionSymbol] 143 | toCompletionSymbols entry s = do 144 | CS.Module _ _ _ mid _ imps _ <- maybeToList entry.moduleAST 145 | let pre = "Prelude" 146 | impNames = S.fromList [ppToText mid' | CS.ImportDecl _ mid' _ _ _ <- imps] 147 | 148 | if | s.kind == I.Module -> return CompletionSymbol 149 | { symbol = s 150 | , moduleName = Nothing 151 | , importEdits = Nothing 152 | } 153 | | (I.symbolParentIdent s == pre && pre `S.notMember` impNames) || I.symbolParentIdent s == ppToText mid -> do 154 | m <- [Nothing, Just $ I.symbolParentIdent s] 155 | return CompletionSymbol 156 | { symbol = s 157 | , moduleName = m 158 | , importEdits = Nothing 159 | } 160 | | otherwise -> do 161 | CS.ImportDecl _ mid' isQual alias spec <- imps 162 | guard $ ppToText mid' == I.symbolParentIdent s 163 | 164 | let isImported = case spec of 165 | Just (CS.Importing _ is) -> flip S.member $ S.fromList $ ppToText <$> (identifiers =<< is) 166 | Just (CS.Hiding _ is) -> flip S.notMember $ S.fromList $ ppToText <$> (identifiers =<< is) 167 | Nothing -> const True 168 | moduleNames = (Just $ ppToText $ fromMaybe mid' alias) : [Nothing | not isQual] 169 | 170 | m <- moduleNames 171 | return CompletionSymbol 172 | { symbol = s 173 | , moduleName = m 174 | , importEdits = if isImported s.ident 175 | then Nothing 176 | else case spec of 177 | Just (CS.Importing _ is) -> do 178 | J.Range _ pos <- currySpanInfo2Range =<< lastSafe is 179 | let range = J.Range pos pos 180 | text | null is = s.ident 181 | | otherwise = ", " <> s.ident 182 | edit = J.TextEdit range text 183 | return [edit] 184 | _ -> return [] 185 | } 186 | 187 | 188 | -- | The fully qualified, possibly aliased, name of the completion symbol. 189 | fullName :: CompletionSymbol -> T.Text 190 | fullName cms | s.kind == I.Module = s.qualIdent 191 | | otherwise = maybe "" (<> ".") moduleName <> s.ident 192 | where s = cms.symbol 193 | moduleName = cms.moduleName 194 | 195 | -- | The fully qualified prefix of the completion query. 196 | fullPrefix :: PosPrefixInfo -> T.Text 197 | fullPrefix query | T.null query.prefixScope = query.prefixText 198 | | otherwise = query.prefixScope <> "." <> query.prefixText 199 | 200 | class CompletionQueryFilter a where 201 | matchesCompletionQuery :: PosPrefixInfo -> a -> Bool 202 | 203 | instance CompletionQueryFilter T.Text where 204 | matchesCompletionQuery query txt = query.prefixText `T.isPrefixOf` txt && T.null query.prefixScope 205 | 206 | instance CompletionQueryFilter Keyword where 207 | matchesCompletionQuery query (Keyword txt) = matchesCompletionQuery query txt 208 | 209 | instance CompletionQueryFilter Local where 210 | matchesCompletionQuery query (Local i _) = query.prefixText `T.isPrefixOf` i 211 | 212 | instance CompletionQueryFilter a => CompletionQueryFilter (Tagged a) where 213 | matchesCompletionQuery query (Tagged _ x) = matchesCompletionQuery query x 214 | 215 | instance CompletionQueryFilter CompletionSymbol where 216 | matchesCompletionQuery query cms = fullPrefix query `T.isPrefixOf` fullName cms 217 | 218 | class ToCompletionItems a where 219 | toCompletionItems :: CompletionOptions -> PosPrefixInfo -> a -> [J.CompletionItem] 220 | 221 | instance ToCompletionItems CompletionSymbol where 222 | -- | Converts a Curry value binding to a completion item. 223 | toCompletionItems opts query cms = [makeCompletion name ciKind detail doc insertText insertTextFormat edits] 224 | where s = cms.symbol 225 | edits = cms.importEdits 226 | name = fromMaybe (fullName cms) $ T.stripPrefix (query.prefixScope <> ".") $ fullName cms 227 | ciKind = case s.kind of 228 | I.ValueFunction | s.arrowArity == Just 0 -> J.CompletionItemKind_Constant 229 | | otherwise -> J.CompletionItemKind_Function 230 | I.ValueConstructor | s.arrowArity == Just 0 -> J.CompletionItemKind_EnumMember 231 | | otherwise -> J.CompletionItemKind_Constructor 232 | I.Module -> J.CompletionItemKind_Module 233 | I.TypeData | length s.constructors == 1 -> J.CompletionItemKind_Struct 234 | | otherwise -> J.CompletionItemKind_Enum 235 | I.TypeNew -> J.CompletionItemKind_Struct 236 | I.TypeAlias -> J.CompletionItemKind_Interface 237 | I.TypeClass -> J.CompletionItemKind_Interface 238 | I.TypeVar -> J.CompletionItemKind_Variable 239 | I.Unknown -> J.CompletionItemKind_Text 240 | insertText | opts.useSnippets = Just $ makeSnippet name s.printedArgumentTypes 241 | | otherwise = Just name 242 | insertTextFormat | opts.useSnippets = Just J.InsertTextFormat_Snippet 243 | | otherwise = Just J.InsertTextFormat_PlainText 244 | detail = s.printedType 245 | doc = Just $ T.intercalate "\n\n" $ filter (not . T.null) 246 | [ if isNothing edits then "" else "_requires import_" 247 | , T.intercalate ", " s.constructors 248 | ] 249 | 250 | instance ToCompletionItems Keyword where 251 | -- | Creates a completion item from a keyword. 252 | toCompletionItems _ _ (Keyword kw) = [makeCompletion label ciKind detail doc insertText insertTextFormat edits] 253 | where label = kw 254 | ciKind = J.CompletionItemKind_Keyword 255 | detail = Nothing 256 | doc = Just "Keyword" 257 | insertText = Just kw 258 | insertTextFormat = Just J.InsertTextFormat_PlainText 259 | edits = Nothing 260 | 261 | instance ToCompletionItems Local where 262 | -- | Creates a completion item from a local variable. 263 | toCompletionItems opts _ (Local i t) = [makeCompletion label ciKind detail doc insertText insertTextFormat edits] 264 | where label = i 265 | ciKind = J.CompletionItemKind_Variable 266 | detail = ppToText <$> t 267 | doc = Just "Local" 268 | argTypes = (ppToText <$>) $ CT.arrowArgs . CT.unpredType =<< maybeToList t 269 | insertText | opts.useSnippets = Just $ makeSnippet i argTypes 270 | | otherwise = Just i 271 | insertTextFormat | opts.useSnippets = Just J.InsertTextFormat_Snippet 272 | | otherwise = Just J.InsertTextFormat_PlainText 273 | edits = Nothing 274 | 275 | instance ToCompletionItems T.Text where 276 | toCompletionItems _ _ txt = [makeCompletion label ciKind detail doc insertText insertTextFormat edits] 277 | where label = txt 278 | ciKind = J.CompletionItemKind_Text 279 | detail = Nothing 280 | doc = Nothing 281 | insertText = Just txt 282 | insertTextFormat = Just J.InsertTextFormat_PlainText 283 | edits = Nothing 284 | 285 | instance ToCompletionItems a => ToCompletionItems (Tagged a) where 286 | toCompletionItems opts query (Tagged tags x) = (J.tags ?~ tags) <$> toCompletionItems opts query x 287 | 288 | -- | Creates a snippet with VSCode-style syntax. 289 | makeSnippet :: T.Text -> [T.Text] -> T.Text 290 | makeSnippet name ts = T.intercalate " " $ name : ((\(i, t) -> "${" <> T.pack (show (i :: Int)) <> ":" <> t <> "}") <$> zip [1..] ts) 291 | 292 | -- | Creates a completion item using the given label, kind, a detail and doc. 293 | makeCompletion :: T.Text -> J.CompletionItemKind -> Maybe T.Text -> Maybe T.Text -> Maybe T.Text -> Maybe J.InsertTextFormat -> Maybe [J.TextEdit] -> J.CompletionItem 294 | makeCompletion l k d c it itf es = J.CompletionItem label labelDetails kind tags detail doc deprecated 295 | preselect sortText filterText insertText 296 | insertTextFormat insertTextMode textEdit textEditText 297 | additionalTextEdits commitChars command xdata 298 | where label = l 299 | labelDetails = Nothing 300 | kind = Just k 301 | tags = Nothing 302 | detail = d 303 | doc = J.InR . J.MarkupContent J.MarkupKind_Markdown <$> c 304 | deprecated = Just False 305 | preselect = Nothing 306 | sortText = Nothing 307 | filterText = Nothing 308 | insertText = it 309 | insertTextFormat = itf 310 | insertTextMode = Nothing 311 | textEdit = Nothing 312 | textEditText = Nothing 313 | additionalTextEdits = es 314 | commitChars = Nothing 315 | command = Nothing 316 | xdata = Nothing 317 | 318 | -------------------------------------------------------------------------------- /src/Curry/LanguageServer/Handlers/TextDocument/Definition.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts, OverloadedStrings, OverloadedRecordDot #-} 2 | module Curry.LanguageServer.Handlers.TextDocument.Definition (definitionHandler) where 3 | 4 | import Control.Lens ((^.)) 5 | import Control.Monad.IO.Class (MonadIO (..)) 6 | import Control.Monad.Trans (lift) 7 | import Control.Monad.Trans.Maybe (MaybeT(..)) 8 | import qualified Curry.LanguageServer.Config as CFG 9 | import qualified Curry.LanguageServer.Index.Store as I 10 | import qualified Curry.LanguageServer.Index.Symbol as I 11 | import Curry.LanguageServer.Index.Resolve (resolveAtPos) 12 | import Curry.LanguageServer.Utils.General (liftMaybe) 13 | import Curry.LanguageServer.Utils.Logging (debugM, infoM) 14 | import Curry.LanguageServer.Utils.Uri (normalizeUriWithPath) 15 | import Curry.LanguageServer.Monad (LSM, getStore) 16 | import Curry.LanguageServer.Utils.Sema (ModuleAST) 17 | import qualified Data.Map as M 18 | import Data.Maybe (fromMaybe, mapMaybe) 19 | import qualified Data.Text as T 20 | import qualified Language.LSP.Server as S 21 | import qualified Language.LSP.Protocol.Types as J 22 | import qualified Language.LSP.Protocol.Lens as J 23 | import Language.LSP.Server (MonadLsp) 24 | import qualified Language.LSP.Protocol.Message as J 25 | 26 | definitionHandler :: S.Handlers LSM 27 | definitionHandler = S.requestHandler J.SMethod_TextDocumentDefinition $ \req responder -> do 28 | debugM "Processing definition request" 29 | let pos = req ^. J.params . J.position 30 | uri = req ^. J.params . J.textDocument . J.uri 31 | normUri <- normalizeUriWithPath uri 32 | store <- getStore 33 | defs <- runMaybeT $ do 34 | lift $ debugM $ "Looking up " <> J.getUri (J.fromNormalizedUri normUri) <> " in " <> T.pack (show (M.keys store.modules)) 35 | entry <- I.getModule normUri 36 | lift $ fetchDefinitions store entry pos 37 | responder $ Right $ J.InR $ maybe (J.InR J.Null) J.InL defs 38 | 39 | fetchDefinitions :: (MonadIO m, MonadLsp CFG.Config m) => I.IndexStore -> I.ModuleStoreEntry -> J.Position -> m [J.DefinitionLink] 40 | fetchDefinitions store entry pos = do 41 | defs <- (fromMaybe [] <$>) $ runMaybeT $ do 42 | ast <- liftMaybe entry.moduleAST 43 | definitions store ast pos 44 | infoM $ "Found " <> T.pack (show (length defs)) <> " definition(s)" 45 | return defs 46 | 47 | definitions :: MonadIO m => I.IndexStore -> ModuleAST -> J.Position -> MaybeT m [J.DefinitionLink] 48 | definitions store ast pos = do 49 | -- Look up identifier under cursor 50 | (symbols, srcRange) <- liftMaybe $ resolveAtPos store ast pos 51 | let locations = mapMaybe (.location) symbols 52 | return [J.DefinitionLink $ J.LocationLink (Just srcRange) destUri destRange destRange | J.Location destUri destRange <- locations] 53 | -------------------------------------------------------------------------------- /src/Curry/LanguageServer/Handlers/TextDocument/DocumentSymbol.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts, OverloadedStrings, OverloadedRecordDot #-} 2 | module Curry.LanguageServer.Handlers.TextDocument.DocumentSymbol (documentSymbolHandler) where 3 | 4 | import Control.Monad.IO.Class (MonadIO (..)) 5 | import Control.Monad.Trans (lift) 6 | import Control.Monad.Trans.Maybe (MaybeT (..)) 7 | import Control.Lens ((^.)) 8 | import qualified Curry.LanguageServer.Config as CFG 9 | import qualified Curry.LanguageServer.Index.Store as I 10 | import Curry.LanguageServer.Utils.Logging (debugM) 11 | import Curry.LanguageServer.Utils.Uri (normalizeUriWithPath) 12 | import Curry.LanguageServer.Utils.Convert (HasDocumentSymbols(..)) 13 | import Curry.LanguageServer.Monad (LSM) 14 | import qualified Data.Text as T 15 | import qualified Language.LSP.Server as S 16 | import qualified Language.LSP.Protocol.Types as J 17 | import qualified Language.LSP.Protocol.Lens as J 18 | import Language.LSP.Server (MonadLsp) 19 | import qualified Language.LSP.Protocol.Message as J 20 | 21 | documentSymbolHandler :: S.Handlers LSM 22 | documentSymbolHandler = S.requestHandler J.SMethod_TextDocumentDocumentSymbol $ \req responder -> do 23 | debugM "Processing document symbols request" 24 | let uri = req ^. J.params . J.textDocument . J.uri 25 | normUri <- normalizeUriWithPath uri 26 | symbols <- runMaybeT $ do 27 | entry <- I.getModule normUri 28 | lift $ fetchDocumentSymbols entry 29 | responder $ Right $ J.InR $ maybe (J.InR J.Null) J.InL symbols 30 | 31 | fetchDocumentSymbols :: (MonadIO m, MonadLsp CFG.Config m) => I.ModuleStoreEntry -> m [J.DocumentSymbol] 32 | fetchDocumentSymbols entry = do 33 | let symbols = maybe [] documentSymbols entry.moduleAST 34 | debugM $ "Found document symbols " <> T.pack (show symbols) 35 | return symbols 36 | -------------------------------------------------------------------------------- /src/Curry/LanguageServer/Handlers/TextDocument/Hover.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts, NumericUnderscores, OverloadedStrings, OverloadedRecordDot, TypeOperators, ViewPatterns #-} 2 | {-# OPTIONS_GHC -Wno-deprecations #-} 3 | module Curry.LanguageServer.Handlers.TextDocument.Hover (hoverHandler) where 4 | 5 | import Control.Applicative ((<|>)) 6 | import Control.Lens ((^.)) 7 | import Control.Monad.Extra (mapMaybeM) 8 | import Control.Monad.IO.Class (MonadIO (..)) 9 | import Control.Monad.Trans (lift) 10 | import Control.Monad.Trans.Maybe (MaybeT (..)) 11 | import qualified Curry.LanguageServer.Config as CFG 12 | import qualified Curry.LanguageServer.Index.Store as I 13 | import qualified Curry.LanguageServer.Index.Symbol as I 14 | import Curry.LanguageServer.Extension (ExtensionPoint (..), ExtensionOutputFormat (..), Extension (..)) 15 | import Curry.LanguageServer.Utils.Convert (ppPredTypeToText, currySpanInfo2Range, ppToText) 16 | import Curry.LanguageServer.Index.Resolve (resolveAtPos) 17 | import Curry.LanguageServer.Utils.General (liftMaybe) 18 | import Curry.LanguageServer.Utils.Logging (debugM, infoM) 19 | import Curry.LanguageServer.Utils.Lookup (findTypeAtPos) 20 | import Curry.LanguageServer.Index.Symbol (symbolParentIdent) 21 | import Curry.LanguageServer.Utils.Syntax (moduleIdentifier) 22 | import Curry.LanguageServer.Utils.Sema (ModuleAST, TypedSpanInfo (..)) 23 | import Curry.LanguageServer.Utils.Uri (normalizeUriWithPath, uriToFilePath) 24 | import Curry.LanguageServer.Monad (LSM, getStore) 25 | import Data.Maybe (listToMaybe, maybeToList, fromMaybe) 26 | import qualified Data.Text as T 27 | import qualified Language.LSP.Server as S 28 | import qualified Language.LSP.Protocol.Types as J 29 | import qualified Language.LSP.Protocol.Lens as J 30 | import qualified Language.LSP.Protocol.Message as J 31 | import Language.LSP.Server (MonadLsp) 32 | import System.Exit (ExitCode (..)) 33 | import System.Process (readCreateProcessWithExitCode, proc) 34 | import System.Timeout (timeout) 35 | 36 | hoverHandler :: S.Handlers LSM 37 | hoverHandler = S.requestHandler J.SMethod_TextDocumentHover $ \req responder -> do 38 | debugM "Processing hover request" 39 | let pos = req ^. J.params . J.position 40 | uri = req ^. J.params . J.textDocument . J.uri 41 | normUri <- normalizeUriWithPath uri 42 | store <- getStore 43 | hover <- runMaybeT $ do 44 | entry <- I.getModule normUri 45 | MaybeT $ fetchHover store entry pos uri 46 | responder $ Right $ maybe (J.InR J.Null) J.InL hover 47 | 48 | fetchHover :: (MonadIO m, MonadLsp CFG.Config m) => I.IndexStore -> I.ModuleStoreEntry -> J.Position -> J.Uri -> m (Maybe J.Hover) 49 | fetchHover store entry pos uri = runMaybeT $ do 50 | ast <- liftMaybe entry.moduleAST 51 | cfg <- lift S.getConfig 52 | let baseHover = maybeToList $ qualIdentHover store ast pos <|> typedSpanInfoHover ast pos 53 | extHovers <- mapMaybeM (extensionHover store ast pos uri) cfg.extensions 54 | hover <- liftMaybe . joinHovers $ baseHover ++ extHovers 55 | lift $ infoM $ "Found hover: " <> previewHover hover 56 | return hover 57 | 58 | qualIdentHover :: I.IndexStore -> ModuleAST -> J.Position -> Maybe J.Hover 59 | qualIdentHover store ast pos = do 60 | (symbols, range) <- resolveAtPos store ast pos 61 | s <- listToMaybe symbols 62 | 63 | let contents = J.InL $ J.mkMarkdownCodeBlock "curry" $ s.qualIdent <> maybe "" (" :: " <>) s.printedType 64 | 65 | return $ J.Hover contents $ Just range 66 | 67 | typedSpanInfoHover :: ModuleAST -> J.Position -> Maybe J.Hover 68 | typedSpanInfoHover ast@(moduleIdentifier -> mid) pos = do 69 | TypedSpanInfo txt t spi <- findTypeAtPos ast pos 70 | 71 | let contents = J.InL $ J.mkMarkdownCodeBlock "curry" $ txt <> " :: " <> maybe "?" (ppPredTypeToText mid) t 72 | range = currySpanInfo2Range spi 73 | 74 | return $ J.Hover contents range 75 | 76 | extensionHover :: MonadIO m => I.IndexStore -> ModuleAST -> J.Position -> J.Uri -> Extension -> m (Maybe J.Hover) 77 | extensionHover store ast@(moduleIdentifier -> mid) pos@(J.Position l c) uri e = case e.extensionPoint of 78 | ExtensionPointHover -> runMaybeT $ do 79 | let symbol = listToMaybe . fst =<< resolveAtPos store ast pos 80 | timeoutSecs = 10 81 | timeoutMicros = timeoutSecs * 1_000_000 82 | templateParams = [ ("currentFile", T.pack (fromMaybe "" (uriToFilePath uri))) 83 | , ("currentUri", J.getUri uri) 84 | , ("currentModule", ppToText mid) 85 | , ("line", T.pack (show l)) 86 | , ("column", T.pack (show c)) 87 | , ("type", fromMaybe "" ((.printedType) =<< symbol)) 88 | , ("identifier", maybe "" (.ident) symbol) 89 | , ("module", maybe "" symbolParentIdent symbol) 90 | , ("symbolKind", T.pack (show (maybe I.Unknown (.kind) symbol))) 91 | ] :: [(T.Text, T.Text)] 92 | applyParam p = T.replace ("{" <> p <> "}") 93 | evalTemplate t = foldr (uncurry applyParam) t templateParams 94 | procOpts = proc (T.unpack e.executable) (T.unpack . (evalTemplate :: T.Text -> T.Text) <$> e.args) 95 | 96 | (exitCode, out, err) <- MaybeT $ liftIO $ timeout timeoutMicros $ readCreateProcessWithExitCode procOpts "" 97 | 98 | let simpleCodeBlock t 99 | | T.null t = "" 100 | | otherwise = "```plaintext\n" <> t <> "\n```" 101 | 102 | text <- case exitCode of 103 | ExitSuccess -> return $ T.unlines 104 | [ "**" <> e.name <> "**" 105 | , "" 106 | , case e.outputFormat of 107 | ExtensionOutputFormatMarkdown -> T.pack out 108 | _ -> simpleCodeBlock (T.pack out) 109 | ] 110 | _ | e.showOutputOnError -> return $ T.unlines 111 | [ "_Extension **" <> e.name <> "** exited with " <> T.pack (show exitCode) <> "_" 112 | , "" 113 | , simpleCodeBlock (T.pack err) 114 | ] 115 | | otherwise -> liftMaybe Nothing 116 | 117 | let contents = J.InL $ J.MarkupContent J.MarkupKind_Markdown text 118 | 119 | return $ J.Hover contents Nothing 120 | _ -> return Nothing 121 | 122 | previewHover :: J.Hover -> T.Text 123 | previewHover = T.unlines . (previewMarkupContent <$>) . normalizeHoverContents . (^. J.contents) 124 | 125 | previewMarkupContent :: J.MarkupContent -> T.Text 126 | previewMarkupContent (J.MarkupContent k t) = case k of 127 | J.MarkupKind_Markdown -> markdownToPlain t 128 | J.MarkupKind_PlainText -> t 129 | 130 | joinHovers :: [J.Hover] -> Maybe J.Hover 131 | joinHovers [] = Nothing 132 | joinHovers hs = Just $ foldr1 mergeHovers hs 133 | 134 | mergeHovers :: J.Hover -> J.Hover -> J.Hover 135 | mergeHovers (J.Hover (normalizeHoverContents -> cs1) r1) (J.Hover (normalizeHoverContents -> cs2) r2) = 136 | J.Hover (J.InL (joinMarkupContent (cs1 ++ cs2))) (r1 <|> r2) 137 | 138 | joinMarkupContent :: [J.MarkupContent] -> J.MarkupContent 139 | joinMarkupContent [] = emptyMarkupContent 140 | joinMarkupContent cs = foldr1 mergeMarkupContent cs 141 | 142 | mergeMarkupContent :: J.MarkupContent -> J.MarkupContent -> J.MarkupContent 143 | mergeMarkupContent (normalizeToMarkdown -> J.MarkupContent _ t1) (normalizeToMarkdown -> J.MarkupContent _ t2) = 144 | J.MarkupContent J.MarkupKind_Markdown $ T.unlines [t1, "", "---", "", t2] 145 | 146 | emptyMarkupContent :: J.MarkupContent 147 | emptyMarkupContent = J.MarkupContent J.MarkupKind_PlainText "" 148 | 149 | normalizeToMarkdown :: J.MarkupContent -> J.MarkupContent 150 | normalizeToMarkdown (J.MarkupContent k t) = case k of 151 | J.MarkupKind_Markdown -> J.MarkupContent k t 152 | J.MarkupKind_PlainText -> J.mkMarkdownCodeBlock "text" t 153 | 154 | normalizeHoverContents :: J.MarkupContent J.|? (J.MarkedString J.|? [J.MarkedString]) -> [J.MarkupContent] 155 | normalizeHoverContents m = case m of 156 | J.InL c -> [c] 157 | J.InR (J.InL s) -> [markedStringToContent s] 158 | J.InR (J.InR ss) -> markedStringToContent <$> ss 159 | 160 | markedStringToContent :: J.MarkedString -> J.MarkupContent 161 | markedStringToContent (J.MarkedString m) = case m of 162 | J.InL t -> J.MarkupContent J.MarkupKind_PlainText t 163 | J.InR (J.MarkedStringWithLanguage l t) -> J.mkMarkdownCodeBlock l t 164 | 165 | markdownToPlain :: T.Text -> T.Text 166 | markdownToPlain t = T.intercalate ", " $ filter includeLine $ T.lines t 167 | where includeLine l = not ("```" `T.isPrefixOf` l || T.null l) 168 | -------------------------------------------------------------------------------- /src/Curry/LanguageServer/Handlers/TextDocument/Notifications.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module Curry.LanguageServer.Handlers.TextDocument.Notifications 3 | ( didOpenHandler 4 | , didChangeHandler 5 | , didSaveHandler 6 | , didCloseHandler 7 | ) where 8 | 9 | import Control.Lens ((^.)) 10 | import Control.Monad (void) 11 | import Control.Monad.Trans (lift) 12 | import Control.Monad.Trans.Maybe (MaybeT (..)) 13 | import Curry.LanguageServer.FileLoader (fileLoader) 14 | import Curry.LanguageServer.Handlers.Diagnostics (emitDiagnostics) 15 | import qualified Curry.LanguageServer.Index.Store as I 16 | import Curry.LanguageServer.Monad (markModuleDirty, LSM) 17 | import Curry.LanguageServer.Utils.Logging (debugM) 18 | import Curry.LanguageServer.Utils.Uri (normalizeUriWithPath) 19 | import qualified Data.Text as T 20 | import qualified Language.LSP.Server as S 21 | import qualified Language.LSP.Protocol.Types as J 22 | import qualified Language.LSP.Protocol.Lens as J 23 | import qualified Language.LSP.Protocol.Message as J 24 | 25 | didOpenHandler :: S.Handlers LSM 26 | didOpenHandler = S.notificationHandler J.SMethod_TextDocumentDidOpen $ \nt -> do 27 | debugM "Processing open notification" 28 | let uri = nt ^. J.params . J.textDocument . J.uri 29 | updateIndexStoreDebounced uri 30 | 31 | didChangeHandler :: S.Handlers LSM 32 | didChangeHandler = S.notificationHandler J.SMethod_TextDocumentDidChange $ \nt -> do 33 | debugM "Processing change notification" 34 | let uri = nt ^. J.params . J.textDocument . J.uri 35 | updateIndexStoreDebounced uri 36 | 37 | didSaveHandler :: S.Handlers LSM 38 | didSaveHandler = S.notificationHandler J.SMethod_TextDocumentDidSave $ \nt -> do 39 | debugM "Processing save notification" 40 | let uri = nt ^. J.params . J.textDocument . J.uri 41 | updateIndexStoreDebounced uri 42 | 43 | didCloseHandler :: S.Handlers LSM 44 | didCloseHandler = S.notificationHandler J.SMethod_TextDocumentDidClose $ \_nt -> do 45 | debugM "Processing close notification" 46 | -- TODO: Remove file from LSM state? 47 | 48 | -- | Schedules recompilation by marking the module as dirty. 49 | updateIndexStoreDebounced :: J.Uri -> LSM () 50 | updateIndexStoreDebounced uri = do 51 | debugM $ "Scheduling recompilation for " <> T.pack (show uri) 52 | markModuleDirty uri $ updateIndexStore uri 53 | 54 | -- | Recompiles and stores the updated compilation for a given URI. 55 | updateIndexStore :: J.Uri -> LSM () 56 | updateIndexStore uri = void $ runMaybeT $ do 57 | fl <- lift fileLoader 58 | cfg <- lift S.getConfig 59 | normUri <- normalizeUriWithPath uri 60 | lift $ I.recompileModule cfg fl normUri 61 | entry <- I.getModule normUri 62 | lift $ emitDiagnostics normUri entry 63 | 64 | -------------------------------------------------------------------------------- /src/Curry/LanguageServer/Handlers/TextDocument/References.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts, OverloadedStrings, NoFieldSelectors, OverloadedRecordDot #-} 2 | module Curry.LanguageServer.Handlers.TextDocument.References (referencesHandler) where 3 | 4 | -- Curry Compiler Libraries + Dependencies 5 | import qualified Curry.Base.SpanInfo as CSPI 6 | 7 | import Control.Lens ((^.)) 8 | import Control.Monad.IO.Class (MonadIO) 9 | import Control.Monad.Trans (MonadTrans (..)) 10 | import Control.Monad.Trans.Maybe (MaybeT (..)) 11 | import qualified Curry.LanguageServer.Config as CFG 12 | import Curry.LanguageServer.Monad (LSM, getStore) 13 | import Curry.LanguageServer.Utils.Convert (currySpanInfo2Location) 14 | import Curry.LanguageServer.Utils.General (liftMaybe, (<.$>), joinFst) 15 | import Curry.LanguageServer.Utils.Logging (debugM, infoM) 16 | import Curry.LanguageServer.Utils.Sema (ModuleAST) 17 | import Curry.LanguageServer.Utils.Syntax (HasQualIdentifiers (..), HasExpressions (expressions), HasQualIdentifier (qualIdentifier)) 18 | import Curry.LanguageServer.Utils.Uri (normalizeUriWithPath) 19 | import Curry.LanguageServer.Index.Resolve (resolveAtPos, resolveQualIdent) 20 | import Curry.LanguageServer.Index.Symbol (Symbol (..)) 21 | import qualified Curry.LanguageServer.Index.Store as I 22 | import qualified Data.Map as M 23 | import Data.Maybe (fromMaybe, maybeToList) 24 | import qualified Data.Text as T 25 | import Language.LSP.Server (MonadLsp) 26 | import qualified Language.LSP.Server as S 27 | import qualified Language.LSP.Protocol.Lens as J 28 | import qualified Language.LSP.Protocol.Message as J 29 | import qualified Language.LSP.Protocol.Types as J 30 | 31 | referencesHandler :: S.Handlers LSM 32 | referencesHandler = S.requestHandler J.SMethod_TextDocumentReferences $ \req responder -> do 33 | debugM "Processing references request" 34 | let pos = req ^. J.params . J.position 35 | uri = req ^. J.params . J.textDocument . J.uri 36 | normUri <- normalizeUriWithPath uri 37 | store <- getStore 38 | refs <- (fromMaybe [] <$>) . runMaybeT $ do 39 | lift $ debugM $ "Looking up " <> J.getUri (J.fromNormalizedUri normUri) <> " in " <> T.pack (show (M.keys store.modules)) 40 | entry <- I.getModule normUri 41 | lift $ fetchReferences store entry pos 42 | responder $ Right $ J.InL refs 43 | 44 | fetchReferences :: (MonadIO m, MonadLsp CFG.Config m) => I.IndexStore -> I.ModuleStoreEntry -> J.Position -> m [J.Location] 45 | fetchReferences store entry pos = do 46 | defs <- (fromMaybe [] <$>) . runMaybeT $ do 47 | ast <- liftMaybe entry.moduleAST 48 | references store ast pos 49 | infoM $ "Found " <> T.pack (show (length defs)) <> " reference(s)" 50 | return defs 51 | 52 | references :: MonadIO m => I.IndexStore -> ModuleAST -> J.Position -> MaybeT m [J.Location] 53 | references store ast pos = do 54 | -- Look up identifier under cursor 55 | (symbols, _) <- liftMaybe $ resolveAtPos store ast pos 56 | sequence $ 57 | [ currySpanInfo2Location spi 58 | | s <- symbols 59 | , (_, mse) <- M.toList store.modules 60 | , ast' <- maybeToList mse.moduleAST 61 | , (qid, spi) <- (withSpanInfo <$> qualIdentifiers ast') 62 | ++ (joinFst $ (maybeToList . qualIdentifier) <.$> withSpanInfo <$> expressions ast') 63 | , s' <- resolveQualIdent store ast' qid 64 | , s.kind == s'.kind && s.qualIdent == s'.qualIdent 65 | ] 66 | where withSpanInfo x = (x, CSPI.getSpanInfo x) 67 | -------------------------------------------------------------------------------- /src/Curry/LanguageServer/Handlers/TextDocument/SignatureHelp.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts, OverloadedStrings, OverloadedRecordDot, MonadComprehensions #-} 2 | module Curry.LanguageServer.Handlers.TextDocument.SignatureHelp (signatureHelpHandler) where 3 | 4 | -- Curry Compiler Libraries + Dependencies 5 | import qualified Curry.Syntax as CS 6 | import qualified Curry.Base.Ident as CI 7 | import qualified Curry.Base.SpanInfo as CSPI 8 | 9 | import Control.Applicative ((<|>)) 10 | import Control.Lens ((^.)) 11 | import Control.Monad.IO.Class (MonadIO (..)) 12 | import Control.Monad.Trans (lift) 13 | import Control.Monad.Trans.Maybe (runMaybeT, MaybeT (..)) 14 | import qualified Curry.LanguageServer.Config as CFG 15 | import Curry.LanguageServer.Index.Resolve (resolveQualIdent) 16 | import qualified Curry.LanguageServer.Index.Store as I 17 | import qualified Curry.LanguageServer.Index.Symbol as I 18 | import Curry.LanguageServer.Monad (LSM, getStore) 19 | import Curry.LanguageServer.Utils.Convert (currySpanInfo2Range) 20 | import Curry.LanguageServer.Utils.General (liftMaybe, lastSafe, snapToLastTokenEnd) 21 | import Curry.LanguageServer.Utils.Sema (ModuleAST) 22 | import Curry.LanguageServer.Utils.Syntax 23 | ( appFull, elementContains, elementsAt 24 | , typeAppFull, HasExpressions (..) 25 | , HasTypeExpressions (..) 26 | ) 27 | import Curry.LanguageServer.Utils.Uri (normalizeUriWithPath) 28 | import Curry.LanguageServer.Utils.Logging (infoM, debugM) 29 | import Data.Bifunctor (bimap) 30 | import Data.Foldable (find) 31 | import Data.Maybe (listToMaybe, maybeToList) 32 | import qualified Data.List.NonEmpty as N 33 | import qualified Data.Text as T 34 | import qualified Language.LSP.Server as S 35 | import qualified Language.LSP.Protocol.Types as J 36 | import qualified Language.LSP.Protocol.Lens as J 37 | import qualified Language.LSP.VFS as VFS 38 | import Language.LSP.Server (MonadLsp) 39 | import qualified Language.LSP.Protocol.Message as J 40 | 41 | signatureHelpHandler :: S.Handlers LSM 42 | signatureHelpHandler = S.requestHandler J.SMethod_TextDocumentSignatureHelp $ \req responder -> do 43 | debugM "Processing signature help request" 44 | let J.SignatureHelpParams doc pos _ _ = req ^. J.params 45 | uri = doc ^. J.uri 46 | normUri <- normalizeUriWithPath uri 47 | store <- getStore 48 | sigHelp <- runMaybeT $ do 49 | entry <- I.getModule normUri 50 | vfile <- MaybeT $ S.getVirtualFile normUri 51 | MaybeT $ fetchSignatureHelp store entry vfile pos 52 | responder $ Right $ maybe (J.InR J.Null) J.InL sigHelp 53 | 54 | fetchSignatureHelp :: (MonadIO m, MonadLsp CFG.Config m) => I.IndexStore -> I.ModuleStoreEntry -> VFS.VirtualFile -> J.Position -> m (Maybe J.SignatureHelp) 55 | fetchSignatureHelp store entry vfile pos@(J.Position l c) = runMaybeT $ do 56 | ast <- liftMaybe entry.moduleAST 57 | let line = VFS.rangeLinesFromVfs vfile $ J.Range (J.Position l 0) (J.Position (l + 1) 0) 58 | c' = snapToLastTokenEnd (T.unpack line) c 59 | pos' = J.Position l c' 60 | (sym, spi, args) <- liftMaybe 61 | $ findExpressionApplication store ast pos' 62 | <|> findTypeApplication store ast pos' 63 | lift $ infoM $ "Found symbol " <> sym.qualIdent 64 | symEnd <- liftMaybe [end | J.Range _ end <- currySpanInfo2Range spi] 65 | let defaultParam | pos >= symEnd = fromIntegral $ length args 66 | | otherwise = 0 67 | activeParam = maybe defaultParam fst $ find (elementContains pos . snd) (zip [0..] args) 68 | activeSig = 0 69 | labelStart = sym.qualIdent <> " :: " 70 | paramSep = " -> " 71 | paramLabels = sym.printedArgumentTypes 72 | paramOffsets = reverse $ snd $ foldl (\(n, offs) lbl -> let n' = n + T.length lbl in (n' + T.length paramSep, (n, n') : offs)) (T.length labelStart, []) paramLabels 73 | params = flip J.ParameterInformation Nothing . J.InR . bimap fromIntegral fromIntegral <$> paramOffsets 74 | label = labelStart <> T.intercalate paramSep (paramLabels ++ maybeToList sym.printedResultType) 75 | sig = J.SignatureInformation label Nothing (Just params) (Just (J.InL activeParam)) 76 | sigs = [sig] 77 | return $ J.SignatureHelp sigs (Just activeSig) (Just (J.InL activeParam)) 78 | 79 | findExpressionApplication :: I.IndexStore -> ModuleAST -> J.Position -> Maybe (I.Symbol, CSPI.SpanInfo, [CSPI.SpanInfo]) 80 | findExpressionApplication store ast pos = lastSafe $ do 81 | e <- elementsAt pos $ expressions ast 82 | let base N.:| args = appFull e 83 | sym <- maybeToList $ lookupBaseExpression store ast base 84 | return (sym, CSPI.getSpanInfo e, CSPI.getSpanInfo <$> args) 85 | 86 | findTypeApplication :: I.IndexStore -> ModuleAST -> J.Position -> Maybe (I.Symbol, CSPI.SpanInfo, [CSPI.SpanInfo]) 87 | findTypeApplication store ast pos = lastSafe $ do 88 | e <- elementsAt pos $ typeExpressions ast 89 | let base N.:| args = typeAppFull e 90 | sym <- maybeToList $ lookupBaseTypeExpression store ast base 91 | return (sym, CSPI.getSpanInfo e, CSPI.getSpanInfo <$> args) 92 | 93 | lookupBaseTypeExpression :: I.IndexStore -> ModuleAST -> CS.TypeExpr -> Maybe I.Symbol 94 | lookupBaseTypeExpression store ast e = listToMaybe $ case e of 95 | CS.ConstructorType _ q -> resolveQualIdent store ast q 96 | CS.VariableType _ i -> resolveQualIdent store ast $ CI.qualify i 97 | _ -> [] 98 | 99 | lookupBaseExpression :: I.IndexStore -> ModuleAST -> CS.Expression a -> Maybe I.Symbol 100 | lookupBaseExpression store ast e = listToMaybe $ case e of 101 | CS.Variable _ _ q -> resolveQualIdent store ast q 102 | CS.Constructor _ _ q -> resolveQualIdent store ast q 103 | _ -> [] 104 | -------------------------------------------------------------------------------- /src/Curry/LanguageServer/Handlers/Workspace/Command.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds, OverloadedStrings, ViewPatterns, TypeOperators #-} 2 | module Curry.LanguageServer.Handlers.Workspace.Command (executeCommandHandler, commands) where 3 | 4 | import Control.Lens ((^.)) 5 | import Control.Monad (void) 6 | import Curry.LanguageServer.Monad (LSM) 7 | import Curry.LanguageServer.Utils.Logging (debugM, infoM) 8 | import qualified Data.Aeson as A 9 | import Data.Maybe (fromMaybe) 10 | import qualified Data.Text as T 11 | import qualified Language.LSP.Server as S 12 | import qualified Language.LSP.Protocol.Types as J 13 | import qualified Language.LSP.Protocol.Lens as J 14 | import qualified Language.LSP.Protocol.Message as J 15 | 16 | executeCommandHandler :: S.Handlers LSM 17 | executeCommandHandler = S.requestHandler J.SMethod_WorkspaceExecuteCommand $ \req responder -> do 18 | debugM "Processing command execution request" 19 | let J.ExecuteCommandParams _ name args = req ^. J.params 20 | res <- executeCommand name $ fromMaybe [] args 21 | responder res 22 | 23 | executeCommand :: T.Text -> [A.Value] -> LSM (Either (J.TResponseError J.Method_WorkspaceExecuteCommand) (A.Value J.|? J.Null)) 24 | executeCommand name args = case lookup name commands of 25 | Just command -> command args 26 | Nothing -> do 27 | let msg = "Unknown command '" <> name <> "'" 28 | return $ Left $ J.TResponseError (J.InR J.ErrorCodes_InvalidParams) msg Nothing 29 | 30 | commands :: [(T.Text, [A.Value] -> LSM (Either (J.TResponseError J.Method_WorkspaceExecuteCommand) (A.Value J.|? J.Null)))] 31 | commands = 32 | [ ("ping", \_args -> do 33 | infoM "Pong!" 34 | return $ Right $ J.InR J.Null) 35 | , ("decl.applyTypeHint", \args -> do 36 | case args of 37 | [A.fromJSON -> A.Success uri, A.fromJSON -> A.Success pos, A.fromJSON -> A.Success text] -> do 38 | let doc = J.OptionalVersionedTextDocumentIdentifier uri $ J.InL 0 39 | range = J.Range pos pos 40 | textEdit = J.TextEdit range $ text <> "\n" 41 | docEdit = J.TextDocumentEdit doc [J.InL textEdit] 42 | docEdits = [docEdit] 43 | workspaceEdit = J.WorkspaceEdit Nothing (Just $ J.InL <$> docEdits) Nothing 44 | params = J.ApplyWorkspaceEditParams (Just "Apply Type Hint") workspaceEdit 45 | void $ S.sendRequest J.SMethod_WorkspaceApplyEdit params (const $ pure ()) 46 | return $ Right $ J.InR J.Null 47 | _ -> return $ Left $ J.TResponseError (J.InR J.ErrorCodes_InvalidParams) "Invalid arguments!" Nothing) 48 | ] 49 | -------------------------------------------------------------------------------- /src/Curry/LanguageServer/Handlers/Workspace/Symbol.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoFieldSelectors, OverloadedStrings, OverloadedRecordDot, FlexibleContexts #-} 2 | module Curry.LanguageServer.Handlers.Workspace.Symbol (workspaceSymbolHandler) where 3 | 4 | import Control.Lens ((^.)) 5 | import Control.Monad.IO.Class (MonadIO (..)) 6 | import qualified Curry.LanguageServer.Config as CFG 7 | import qualified Curry.LanguageServer.Index.Store as I 8 | import qualified Curry.LanguageServer.Index.Symbol as I 9 | import Curry.LanguageServer.Monad (LSM, getStore) 10 | import Curry.LanguageServer.Utils.Logging (debugM, infoM) 11 | import Data.Maybe (mapMaybe) 12 | import qualified Data.Text as T 13 | import qualified Language.LSP.Server as S 14 | import qualified Language.LSP.Protocol.Types as J 15 | import qualified Language.LSP.Protocol.Lens as J 16 | import qualified Language.LSP.Protocol.Message as J 17 | import Language.LSP.Server (MonadLsp) 18 | 19 | workspaceSymbolHandler :: S.Handlers LSM 20 | workspaceSymbolHandler = S.requestHandler J.SMethod_WorkspaceSymbol $ \req responder -> do 21 | debugM "Processing workspace symbols request" 22 | let query = req ^. J.params . J.query 23 | store <- getStore 24 | symbols <- fetchWorkspaceSymbols store query 25 | let maxSymbols = 150 26 | responder $ Right $ J.InL $ take maxSymbols symbols 27 | 28 | fetchWorkspaceSymbols :: (MonadIO m, MonadLsp CFG.Config m) => I.IndexStore -> T.Text -> m [J.SymbolInformation] 29 | fetchWorkspaceSymbols store query = do 30 | debugM $ "Searching " <> T.pack (show (I.storedSymbolCount store)) <> " symbol(s)..." 31 | let symbols = mapMaybe toWorkspaceSymbol $ I.storedSymbolsWithPrefix query store 32 | infoM $ "Found " <> T.pack (show (length symbols)) <> " symbol(s)" 33 | return symbols 34 | 35 | toWorkspaceSymbol :: I.Symbol -> Maybe J.SymbolInformation 36 | toWorkspaceSymbol s = J.SymbolInformation name kind tags containerName deprecated <$> s.location 37 | where name = s.ident 38 | kind = case s.kind of 39 | I.ValueFunction | s.arrowArity == Just 0 -> J.SymbolKind_Constant 40 | | otherwise -> J.SymbolKind_Function 41 | I.ValueConstructor | s.arrowArity == Just 0 -> J.SymbolKind_EnumMember 42 | | otherwise -> J.SymbolKind_Constructor 43 | I.Module -> J.SymbolKind_Module 44 | I.TypeData | length s.constructors == 1 -> J.SymbolKind_Struct 45 | | otherwise -> J.SymbolKind_Enum 46 | I.TypeNew -> J.SymbolKind_Struct 47 | I.TypeAlias -> J.SymbolKind_Interface 48 | I.TypeClass -> J.SymbolKind_Interface 49 | I.TypeVar -> J.SymbolKind_Variable 50 | I.Unknown -> J.SymbolKind_Namespace 51 | tags = Nothing 52 | deprecated = Nothing 53 | containerName = Just $ I.symbolParentIdent s 54 | -------------------------------------------------------------------------------- /src/Curry/LanguageServer/Index/Convert.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings, FlexibleInstances, ViewPatterns #-} 2 | module Curry.LanguageServer.Index.Convert 3 | ( ToSymbols (..) 4 | ) where 5 | 6 | -- Curry Compiler Libraries + Dependencies 7 | import qualified Curry.Base.Ident as CI 8 | import qualified Curry.Frontend.Base.TopEnv as CTE 9 | import qualified Curry.Frontend.Base.Types as CT 10 | import qualified Curry.Frontend.Base.Kinds as CK 11 | import qualified Curry.Frontend.Env.TypeConstructor as CETC 12 | import qualified Curry.Frontend.Env.Value as CEV 13 | 14 | import Control.Applicative ((<|>)) 15 | import Control.Monad.IO.Class (MonadIO (..)) 16 | import Control.Monad.Trans.Maybe (runMaybeT) 17 | import Curry.LanguageServer.Index.Symbol (Symbol (..), SymbolKind (..)) 18 | import Curry.LanguageServer.Utils.Convert (ppToText, currySpanInfo2Location, ppToTextPrec) 19 | import Curry.LanguageServer.Utils.General (lastSafe) 20 | import Data.Default (Default (..)) 21 | import Data.List (inits) 22 | import Data.Maybe (fromMaybe) 23 | import qualified Data.Text as T 24 | 25 | class ToSymbols s where 26 | toSymbols :: MonadIO m => s -> m [Symbol] 27 | 28 | instance ToSymbols (CI.QualIdent, CEV.ValueInfo) where 29 | toSymbols (q, vinfo) 30 | | CI.isQualified q' = pure <$> case vinfo of 31 | CEV.DataConstructor _ _ ls t -> (\s -> s { constructors = ppToText <$> ls }) 32 | <$> makeValueSymbol ValueConstructor q' t 33 | CEV.NewtypeConstructor _ _ t -> makeValueSymbol ValueConstructor q' t 34 | CEV.Value _ _ _ t -> makeValueSymbol ValueFunction q' t 35 | CEV.Label _ _ t -> makeValueSymbol ValueFunction q' t 36 | | otherwise = return [] 37 | where q' = qualifyWithModuleFrom vinfo q 38 | 39 | instance ToSymbols (CI.QualIdent, CETC.TypeInfo) where 40 | toSymbols (q, tinfo) 41 | | CI.isQualified q' = case tinfo of 42 | CETC.DataType _ k _ -> pure <$> makeTypeSymbol TypeData q' k 43 | CETC.RenamingType _ k _ -> pure <$> makeTypeSymbol TypeNew q' k 44 | CETC.AliasType _ k _ _ -> pure <$> makeTypeSymbol TypeAlias q' k 45 | CETC.TypeClass _ k _ -> pure <$> makeTypeSymbol TypeClass q' k 46 | CETC.TypeVar _ -> return [] 47 | | otherwise = return [] 48 | where q' = qualifyWithModuleFrom tinfo q 49 | 50 | instance ToSymbols CI.ModuleIdent where 51 | toSymbols mid = do 52 | loc <- runMaybeT $ currySpanInfo2Location mid 53 | return $ do 54 | quals <- tail $ inits $ T.pack <$> CI.midQualifiers mid 55 | return def 56 | { kind = Module 57 | , qualIdent = T.intercalate "." quals 58 | , ident = fromMaybe "" $ lastSafe quals 59 | , location = loc 60 | } 61 | 62 | qualifyWithModuleFrom :: CTE.Entity a => a -> CI.QualIdent -> CI.QualIdent 63 | qualifyWithModuleFrom (CTE.origName -> CI.qidModule -> mid) q = q { CI.qidModule = CI.qidModule q <|> mid } 64 | 65 | makeValueSymbol :: MonadIO m => SymbolKind -> CI.QualIdent -> CT.TypeScheme -> m Symbol 66 | makeValueSymbol k q t = do 67 | loc <- runMaybeT $ currySpanInfo2Location $ CI.qidIdent q 68 | return def 69 | { kind = k 70 | , qualIdent = ppToText q 71 | , ident = ppToText $ CI.qidIdent q 72 | , printedType = Just $ ppToText t 73 | -- We explicitly perform the Type -> TypeExpr conversion here since 74 | -- the Pretty Type instance ignores the precedence. 75 | , printedArgumentTypes = ppToTextPrec 2 . CT.fromType CI.identSupply <$> CT.arrowArgs (CT.rawType t) 76 | , printedResultType = Just $ ppToText $ CT.arrowBase (CT.rawType t) 77 | , arrowArity = Just $ CT.arrowArity $ CT.rawType t 78 | , location = loc 79 | } 80 | 81 | makeTypeSymbol :: MonadIO m => SymbolKind -> CI.QualIdent -> CK.Kind -> m Symbol 82 | makeTypeSymbol k q k' = do 83 | loc <- runMaybeT $ currySpanInfo2Location $ CI.qidIdent q 84 | return def 85 | { kind = k 86 | , qualIdent = ppToText q 87 | , ident = ppToText $ CI.qidIdent q 88 | , printedType = Just $ ppToText k' 89 | -- We explicitly perform the Kind conversion here since 90 | -- the Pretty Kind instance ignores the precedence. 91 | , printedArgumentTypes = ppToTextPrec 2 . CK.fromKind <$> CK.kindArgs k' 92 | , printedResultType = Just $ ppToText $ kindBase k' 93 | , arrowArity = Just $ CK.kindArity k' 94 | , location = loc 95 | } 96 | where kindBase (CK.KindArrow _ k'') = kindBase k'' 97 | kindBase k'' = k'' 98 | -------------------------------------------------------------------------------- /src/Curry/LanguageServer/Index/Resolve.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoFieldSelectors #-} 2 | -- | Lookup and resolution with the index. 3 | module Curry.LanguageServer.Index.Resolve 4 | ( resolveAtPos 5 | , resolveQualIdent 6 | ) where 7 | 8 | -- Curry Compiler Libraries + Dependencies 9 | import qualified Curry.Base.Ident as CI 10 | import qualified Curry.Syntax as CS 11 | 12 | import Control.Applicative (Alternative ((<|>))) 13 | import Control.Monad (join, when) 14 | import Control.Monad.Trans.Maybe (MaybeT(..)) 15 | import qualified Curry.LanguageServer.Index.Store as I 16 | import qualified Curry.LanguageServer.Index.Symbol as I 17 | import Curry.LanguageServer.Index.Symbol (Symbol (..)) 18 | import Curry.LanguageServer.Utils.Convert (currySpanInfo2Range, currySpanInfo2Location, ppToText) 19 | import Curry.LanguageServer.Utils.Sema (ModuleAST) 20 | import Curry.LanguageServer.Utils.Lookup (findQualIdentAtPos, findModuleIdentAtPos, findScopeAtPos) 21 | import qualified Language.LSP.Protocol.Types as J 22 | import Data.Default (Default(def)) 23 | import qualified Data.Map as M 24 | import System.IO.Unsafe (unsafePerformIO) 25 | 26 | -- | Resolves the identifier at the given position. 27 | resolveAtPos :: I.IndexStore -> ModuleAST -> J.Position -> Maybe ([I.Symbol], J.Range) 28 | resolveAtPos store ast pos = resolveLocalIdentAtPos ast pos 29 | <|> resolveQualIdentAtPos store ast pos 30 | <|> resolveModuleIdentAtPos store ast pos 31 | 32 | -- | Resolves the qualified identifier at the given position. 33 | resolveQualIdentAtPos :: I.IndexStore -> ModuleAST -> J.Position -> Maybe ([I.Symbol], J.Range) 34 | resolveQualIdentAtPos store ast pos = do 35 | (qid, spi) <- findQualIdentAtPos ast pos 36 | range <- currySpanInfo2Range spi 37 | let symbols = resolveQualIdent store ast qid 38 | return (symbols, range) 39 | 40 | -- | Resolves the module identifier at the given position. 41 | resolveModuleIdentAtPos :: I.IndexStore -> ModuleAST -> J.Position -> Maybe ([I.Symbol], J.Range) 42 | resolveModuleIdentAtPos store ast pos = do 43 | (mid, spi) <- findModuleIdentAtPos ast pos 44 | range <- currySpanInfo2Range spi 45 | let symbols = resolveModuleIdent store mid 46 | return (symbols, range) 47 | 48 | -- | Resolves the local identifier at the given position. 49 | resolveLocalIdentAtPos :: ModuleAST -> J.Position -> Maybe ([I.Symbol], J.Range) 50 | resolveLocalIdentAtPos ast pos = do 51 | let scope = findScopeAtPos ast pos 52 | (qid, spi) <- findQualIdentAtPos ast pos 53 | range <- currySpanInfo2Range spi 54 | let symbols = [def { ident = ppToText lid 55 | , qualIdent = ppToText lid 56 | , printedType = ppToText <$> join lty 57 | , location = unsafePerformIO (runMaybeT (currySpanInfo2Location lid)) -- SAFETY: We expect this conversion to be pure 58 | } 59 | | (_, (lid, lty)) <- M.toList scope 60 | , CI.idName lid == CI.idName (CI.qidIdent qid) 61 | ] 62 | -- Fail the computation when no local source identifier could be found 63 | when (null symbols) 64 | Nothing 65 | return (symbols, range) 66 | 67 | -- | Resolves the qualified identifier at the given position. 68 | resolveQualIdent :: I.IndexStore -> ModuleAST -> CI.QualIdent -> [I.Symbol] 69 | resolveQualIdent store (CS.Module _ _ _ mid _ imps _) qid = do 70 | -- TODO: Deal with aliases 71 | qid' <- qid : (flip CI.qualQualify qid <$> ([mid, CI.mkMIdent ["Prelude"]] 72 | ++ [mid' | CS.ImportDecl _ mid' _ _ _ <- imps])) 73 | tryFilterFromCurrySource $ I.storedSymbolsByQualIdent qid' store 74 | 75 | -- | Resolves the module identifier at the given position. 76 | resolveModuleIdent :: I.IndexStore -> CI.ModuleIdent -> [I.Symbol] 77 | resolveModuleIdent store mid = tryFilterFromCurrySource $ I.storedModuleSymbolsByModuleIdent mid store 78 | 79 | -- | Tries filtering symbols from a Curry source file. 80 | tryFilterFromCurrySource :: [I.Symbol] -> [I.Symbol] 81 | tryFilterFromCurrySource symbols | any I.symbolIsFromCurrySource symbols = filter I.symbolIsFromCurrySource symbols 82 | | otherwise = symbols 83 | -------------------------------------------------------------------------------- /src/Curry/LanguageServer/Index/Store.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts, TupleSections, DuplicateRecordFields, NoFieldSelectors, OverloadedStrings, OverloadedRecordDot #-} 2 | {-# OPTIONS_GHC -Wno-ambiguous-fields #-} 3 | module Curry.LanguageServer.Index.Store 4 | ( ModuleStoreEntry (..) 5 | , IndexStore (..) 6 | , storedModuleCount 7 | , storedSymbolCount 8 | , storedModule 9 | , storedModuleByIdent 10 | , storedModules 11 | , storedSymbols 12 | , storedSymbolsWithPrefix 13 | , storedSymbolsByQualIdent 14 | , storedModuleSymbolsByModuleIdent 15 | , storedModuleSymbolsWithPrefix 16 | , addWorkspaceDir 17 | , recompileModule 18 | , getModuleCount 19 | , getModule 20 | , getModuleList 21 | , getModuleAST 22 | ) where 23 | 24 | -- Curry Compiler Libraries + Dependencies 25 | import qualified Curry.Base.Ident as CI 26 | import qualified Curry.Base.Message as CM 27 | import qualified Curry.Files.Filenames as CFN 28 | import qualified Curry.Frontend.Base.TopEnv as CT 29 | import qualified Curry.Frontend.CompilerEnv as CE 30 | 31 | import Control.Exception (SomeException) 32 | import Control.Monad (forM_, join, void, unless, filterM) 33 | import Control.Monad.Catch (MonadCatch (..)) 34 | import Control.Monad.Extra (whenM) 35 | import Control.Monad.State 36 | import Control.Monad.Trans.Maybe 37 | import qualified Curry.LanguageServer.Compiler as C 38 | import Curry.LanguageServer.CPM.Deps (generatePathsJsonWithCPM, readPathsJson) 39 | import Curry.LanguageServer.CPM.Monad (runCPMM) 40 | import qualified Curry.LanguageServer.Config as CFG 41 | import Curry.LanguageServer.Index.Convert 42 | import Curry.LanguageServer.Index.Symbol 43 | import Curry.LanguageServer.Utils.Convert 44 | import Curry.LanguageServer.Utils.General 45 | import Curry.LanguageServer.Utils.Logging (infoM, debugM, warnM) 46 | import Curry.LanguageServer.Utils.Sema (ModuleAST) 47 | import Curry.LanguageServer.Utils.Syntax (moduleIdentifier) 48 | import Curry.LanguageServer.Utils.Uri 49 | import Data.Default 50 | import Data.Function (on) 51 | import Data.List (unionBy, isPrefixOf, foldl') 52 | import Data.List.Extra (nubOrdOn, nubOrd) 53 | import qualified Data.Map as M 54 | import Data.Maybe (fromMaybe, maybeToList, catMaybes) 55 | import qualified Data.Set as S 56 | import qualified Data.Text as T 57 | import qualified Data.Text.IO as TIO 58 | import qualified Data.Text.Encoding as TE 59 | import qualified Data.Trie as TR 60 | import qualified Language.LSP.Protocol.Types as J 61 | import System.Directory (doesFileExist, doesDirectoryExist) 62 | import System.Exit (ExitCode(ExitSuccess)) 63 | import System.FilePath ((<.>), (), takeDirectory, takeExtension, takeFileName) 64 | import qualified System.FilePath.Glob as G 65 | import System.Process (readProcessWithExitCode) 66 | import Language.LSP.Server (MonadLsp) 67 | 68 | -- | An index store entry containing the parsed AST, the compilation environment 69 | -- and diagnostic messages. 70 | data ModuleStoreEntry = ModuleStoreEntry { moduleAST :: Maybe ModuleAST 71 | , errorMessages :: [CM.Message] 72 | , warningMessages :: [CM.Message] 73 | , projectDir :: Maybe FilePath 74 | , importPaths :: [FilePath] 75 | } 76 | 77 | 78 | 79 | -- | An in-memory map of URIs to parsed modules and 80 | -- unqualified symbol names to actual symbols/symbol information. 81 | -- Since (unqualified) symbol names can be ambiguous, a trie leaf 82 | -- holds a list of symbol entries rather than just a single one. 83 | data IndexStore = IndexStore { modules :: M.Map J.NormalizedUri ModuleStoreEntry 84 | -- Symbols keyed by unqualified name 85 | , symbols :: TR.Trie [Symbol] 86 | -- Module symbols keyed by qualified name 87 | , moduleSymbols :: TR.Trie [Symbol] 88 | } 89 | 90 | instance Default ModuleStoreEntry where 91 | def = ModuleStoreEntry { moduleAST = Nothing 92 | , warningMessages = [] 93 | , errorMessages = [] 94 | , projectDir = Nothing 95 | , importPaths = [] 96 | } 97 | 98 | instance Default IndexStore where 99 | def = IndexStore { modules = M.empty, symbols = TR.empty, moduleSymbols = TR.empty } 100 | 101 | -- | Fetches the number of stored modules. 102 | storedModuleCount :: IndexStore -> Int 103 | storedModuleCount = M.size . (.modules) 104 | 105 | -- | Fetches the number of stored symbols. 106 | storedSymbolCount :: IndexStore -> Int 107 | storedSymbolCount = TR.size . (.symbols) 108 | 109 | -- | Fetches the given entry in the store. 110 | storedModule :: J.NormalizedUri -> IndexStore -> Maybe ModuleStoreEntry 111 | storedModule uri = M.lookup uri . (.modules) 112 | 113 | -- | Fetches an entry in the store by module identifier. 114 | storedModuleByIdent :: CI.ModuleIdent -> IndexStore -> IO (Maybe ModuleStoreEntry) 115 | storedModuleByIdent mident store = flip storedModule store <$> uri 116 | where filePath = CFN.moduleNameToFile mident <.> "curry" 117 | uri = filePathToNormalizedUri filePath 118 | 119 | -- | Fetches the entries in the store as a list. 120 | storedModules :: IndexStore -> [(J.NormalizedUri, ModuleStoreEntry)] 121 | storedModules = M.toList . (.modules) 122 | 123 | -- | Fetches all symbols. 124 | storedSymbols :: IndexStore -> [Symbol] 125 | storedSymbols = join . TR.toListBy (const id) . (.symbols) 126 | 127 | -- | Fetches the given (unqualified) symbol names in the store. 128 | storedSymbolsByKey :: T.Text -> IndexStore -> [Symbol] 129 | storedSymbolsByKey t = join . maybeToList . TR.lookup (TE.encodeUtf8 t) . (.symbols) 130 | 131 | -- | Fetches the list of symbols starting with the given prefix. 132 | storedSymbolsWithPrefix :: T.Text -> IndexStore -> [Symbol] 133 | storedSymbolsWithPrefix pre = join . TR.elems . TR.submap (TE.encodeUtf8 pre) . (.symbols) 134 | 135 | -- | Fetches stored symbols by qualified identifier. 136 | storedSymbolsByQualIdent :: CI.QualIdent -> IndexStore -> [Symbol] 137 | storedSymbolsByQualIdent q = filter ((== ppToText q) . (.qualIdent)) . storedSymbolsByKey name 138 | where name = T.pack $ CI.idName $ CI.qidIdent q 139 | 140 | -- | Fetches the given (qualified) module symbol names in the store. 141 | storedModuleSymbolsByKey :: T.Text -> IndexStore -> [Symbol] 142 | storedModuleSymbolsByKey t = join . maybeToList . TR.lookup (TE.encodeUtf8 t) . (.moduleSymbols) 143 | 144 | -- | Fetches stored symbols by qualified identifier. 145 | storedModuleSymbolsByModuleIdent :: CI.ModuleIdent -> IndexStore -> [Symbol] 146 | storedModuleSymbolsByModuleIdent = storedModuleSymbolsByKey . ppToText 147 | 148 | -- | Fetches stored module symbols starting with the given prefix. 149 | storedModuleSymbolsWithPrefix :: T.Text -> IndexStore -> [Symbol] 150 | storedModuleSymbolsWithPrefix pre = join . TR.elems . TR.submap (TE.encodeUtf8 pre) . (.moduleSymbols) 151 | 152 | -- | Compiles the given directory recursively and stores its entries. 153 | addWorkspaceDir :: (MonadState IndexStore m, MonadIO m, MonadLsp CFG.Config m, MonadCatch m) => CFG.Config -> C.FileLoader -> FilePath -> m () 154 | addWorkspaceDir cfg fl dirPath = void $ runMaybeT $ do 155 | files <- lift $ findCurrySourcesInWorkspace cfg dirPath 156 | lift $ do 157 | mapM_ (\(i, file) -> recompileFile i (length files) cfg fl file.importPaths (Just file.projectDir) file.path) (zip [1..] files) 158 | infoM $ "Added workspace directory " <> T.pack dirPath 159 | 160 | -- | Recompiles the module entry with the given URI and stores the output. 161 | recompileModule :: (MonadState IndexStore m, MonadIO m, MonadLsp CFG.Config m, MonadCatch m) => CFG.Config -> C.FileLoader -> J.NormalizedUri -> m () 162 | recompileModule cfg fl uri = void $ runMaybeT $ do 163 | filePath <- liftMaybe $ J.uriToFilePath $ J.fromNormalizedUri uri 164 | lift $ do 165 | recompileFile 1 1 cfg fl [] Nothing filePath 166 | debugM $ "Recompiled entry " <> T.pack (show uri) 167 | 168 | data CurrySourceFile = CurrySourceFile { projectDir :: FilePath 169 | , importPaths :: [FilePath] 170 | , path :: FilePath 171 | } 172 | 173 | -- | Finds the Curry source files along with its import paths in a workspace. Recognizes CPM projects. 174 | findCurrySourcesInWorkspace :: (MonadIO m, MonadLsp CFG.Config m) => CFG.Config -> FilePath -> m [CurrySourceFile] 175 | findCurrySourcesInWorkspace cfg dirPath = do 176 | -- First and foremost, the language server tries to locate CPM packages by their 'package.json' 177 | cpmProjPaths <- walkCurryProjects ["package.json"] dirPath 178 | -- In addition to that, it also supports non-CPM packages located at '.curry/language-server/paths.json' 179 | pathsJsonProjPaths <- walkCurryProjects [".curry", "language-server", "paths.json"] dirPath 180 | -- If nothing is found, default to the workspace directory 181 | let projPaths = fromMaybe [dirPath] $ nothingIfNull $ nubOrd $ cpmProjPaths ++ pathsJsonProjPaths 182 | nubOrdOn (.path) . join <$> mapM (findCurrySourcesInProject cfg) projPaths 183 | 184 | -- | Finds the Curry source files in a (project) directory. 185 | findCurrySourcesInProject :: (MonadIO m, MonadLsp CFG.Config m) => CFG.Config -> FilePath -> m [CurrySourceFile] 186 | findCurrySourcesInProject cfg dirPath = do 187 | let curryPath = cfg.curryPath 188 | cpmPath = curryPath ++ " cypm" 189 | libPath binPath = takeDirectory (takeDirectory binPath) "lib" 190 | 191 | infoM $ "Entering project " <> T.pack dirPath <> "..." 192 | 193 | whenM (liftIO $ doesFileExist $ dirPath "package.json") $ do 194 | infoM "Resolving dependencies automatically since package.json was found..." 195 | cpmResult <- runCPMM $ generatePathsJsonWithCPM dirPath cpmPath 196 | case cpmResult of 197 | Right _ -> infoM $ "Successfully updated paths.json using '" <> T.pack cpmPath <> "'!" 198 | Left _ -> warnM $ "Could not update paths.json using " <> T.pack cpmPath <> " (try running '" <> T.pack cpmPath <> " install'), trying to read paths.json anyway..." 199 | 200 | infoM "Reading paths.json..." 201 | pathsResult <- runCPMM $ readPathsJson dirPath 202 | paths <- case pathsResult of 203 | Right paths -> do 204 | infoM $ "Successfully read paths.json: " <> T.pack (show (length paths)) <> " path(s)" 205 | return paths 206 | Left e -> do 207 | warnM $ "Could not read paths.json (" <> T.pack e <> "), trying fallback resolution of Curry standard libraries by locating the '" <> T.pack curryPath <> "' executable..." 208 | 209 | (exitCode, fullCurryPath, _) <- liftIO $ readProcessWithExitCode "which" [curryPath] [] 210 | let curryLibPath = libPath fullCurryPath 211 | 212 | if exitCode == ExitSuccess then do 213 | infoM $ "Found Curry standard library at " <> T.pack curryLibPath 214 | return [curryLibPath] 215 | else do 216 | warnM "Could not find Curry standard libraries, this might result in 'missing Prelude' errors..." 217 | return [] 218 | 219 | infoM "Searching for sources..." 220 | projSources <- walkCurrySourceFiles dirPath 221 | 222 | return $ CurrySourceFile dirPath paths <$> projSources 223 | 224 | -- | Recursively finds all projects in a directory containing the given identifying file. 225 | walkCurryProjects :: (MonadIO m, MonadLsp CFG.Config m) => [FilePath] -> FilePath -> m [FilePath] 226 | walkCurryProjects relPath dirPath = do 227 | files <- walkIgnoringHidden dirPath 228 | filterM (liftIO . doesFileExist . applyRelPath) files 229 | where applyRelPath = flip (foldl' ()) relPath 230 | 231 | -- | Recursively finds all Curry source files in a directory. 232 | walkCurrySourceFiles :: (MonadIO m, MonadLsp CFG.Config m) => FilePath -> m [FilePath] 233 | walkCurrySourceFiles = (filter ((== ".curry") . takeExtension) <$>) . walkIgnoringHidden 234 | 235 | -- | Recursively finds Curry source files, ignoring directories starting with dots 236 | -- and those specified in .curry-language-server-ignore. 237 | -- TODO: Respect parent gitignore also in subdirectories (may require changes to walkFilesWith 238 | -- to aggregate the state across recursive calls, perhaps by requiring a Monoid instance?) 239 | walkIgnoringHidden :: (MonadIO m, MonadLsp CFG.Config m) => FilePath -> m [FilePath] 240 | walkIgnoringHidden = walkFilesWith WalkConfiguration 241 | { onEnter = \fp -> do 242 | ignorePaths <- filterM (liftIO . doesFileExist) $ (fp ) <$> [".curry-language-server-ignore", ".gitignore"] 243 | ignored <- join <$> mapM readIgnoreFile ignorePaths 244 | unless (null ignored) $ 245 | infoM $ "In '" <> T.pack (takeFileName fp) <> "' ignoring " <> T.pack (show (G.decompile <$> ignored)) 246 | return $ Just ignored 247 | , shouldIgnore = \ignored fp -> do 248 | isDir <- liftIO $ doesDirectoryExist fp 249 | let fn = takeFileName fp 250 | matchesFn pat = any (G.match pat) $ catMaybes [Just fn, if isDir then Just (fn ++ "/") else Nothing] 251 | matchingIgnores = filter matchesFn ignored 252 | unless (null matchingIgnores) $ 253 | debugM $ "Ignoring '" <> T.pack fn <> "' since it matches " <> T.pack (show (G.decompile <$> matchingIgnores)) 254 | return $ not (null matchingIgnores) || "." `isPrefixOf` fn 255 | , includeDirectories = True 256 | , includeFiles = True 257 | } 258 | 259 | -- | Reads the given ignore file, fetching the ignored (relative) paths. 260 | readIgnoreFile :: MonadIO m => FilePath -> m [G.Pattern] 261 | readIgnoreFile = liftIO . (map (G.simplify . G.compile . T.unpack) . filter useLine . T.lines <$>) . TIO.readFile 262 | where useLine l = not (T.null l) && not ("#" `T.isPrefixOf` l) 263 | 264 | -- | Recompiles the entry with its dependencies using explicit paths and stores the output. 265 | recompileFile :: (MonadState IndexStore m, MonadIO m, MonadLsp CFG.Config m, MonadCatch m) => Int -> Int -> CFG.Config -> C.FileLoader -> [FilePath] -> Maybe FilePath -> FilePath -> m () 266 | recompileFile i total cfg fl importPaths dirPath filePath = void $ do 267 | infoM $ "[" <> T.pack (show i) <> " of " <> T.pack (show total) <> "] (Re)compiling file " <> T.pack (takeFileName filePath) 268 | 269 | uri <- filePathToNormalizedUri filePath 270 | ms <- gets (.modules) 271 | 272 | -- Regarding the ambiguous-fields warning, perhaps this is https://gitlab.haskell.org/ghc/ghc/-/issues/21443 ? 273 | let defEntry = (def { projectDir = dirPath, importPaths = importPaths }) :: ModuleStoreEntry 274 | outDirPath = CFN.defaultOutDir "language-server" 275 | importPaths' = outDirPath : (M.findWithDefault defEntry uri ms).importPaths 276 | aux = C.CompileAuxiliary { C.fileLoader = fl } 277 | 278 | (co, cs) <- catch 279 | (C.compileCurryFileWithDeps cfg aux importPaths' outDirPath filePath) 280 | (\e -> return $ C.failedCompilation $ "Compilation failed: " ++ show (e :: SomeException)) 281 | 282 | let msgNormUri msg = (fromMaybe uri <$>) $ runMaybeT $ do 283 | uri' <- currySpanInfo2Uri $ CM.msgSpanInfo msg 284 | normalizeUriWithPath uri' 285 | 286 | -- Ignore parses from interface files, only consider source files for now 287 | asts <- mapM (\(fp, mdl) -> (, mdl) <$> filePathToNormalizedUri fp) $ filter ((".curry" `T.isSuffixOf`) . T.pack . fst) co 288 | 289 | warns <- groupIntoMapByM msgNormUri cs.warnings 290 | errors <- groupIntoMapByM msgNormUri cs.errors 291 | 292 | debugM $ "Recompiled module paths: " <> T.pack (show (fst <$> asts)) 293 | 294 | -- Update store with compiled modules 295 | 296 | let modifyEntry f = M.alter (Just . f . fromMaybe defEntry) 297 | 298 | forM_ asts $ \(uri', (env, ast)) -> do 299 | -- Update module store 300 | let updateEntry e = e 301 | { warningMessages = M.findWithDefault [] uri' warns 302 | , errorMessages = M.findWithDefault [] uri' errors 303 | , moduleAST = Just ast 304 | -- , mseCompilerEnv = Just env 305 | } 306 | modify $ \s -> s { modules = modifyEntry updateEntry uri' s.modules } 307 | 308 | -- Update symbol store 309 | valueSymbols <- join <$> mapM toSymbols (CT.allBindings $ CE.valueEnv env) 310 | typeSymbols <- join <$> mapM toSymbols (CT.allBindings $ CE.tyConsEnv env) 311 | modSymbols <- toSymbols (moduleIdentifier ast) 312 | 313 | let symbolDelta = valueSymbols ++ typeSymbols ++ modSymbols 314 | combiner = unionBy ((==) `on` (\s' -> (s'.kind, s'.qualIdent, symbolIsFromCurrySource s'))) 315 | modify $ \s -> s 316 | { symbols = insertAllIntoTrieWith combiner ((\s' -> (TE.encodeUtf8 s'.ident, [s'])) <$> symbolDelta) s.symbols 317 | , moduleSymbols = insertAllIntoTrieWith (unionBy ((==) `on` (.qualIdent))) ((\s' -> (TE.encodeUtf8 s'.qualIdent, [s'])) <$> modSymbols) s.moduleSymbols 318 | } 319 | 320 | -- Update store with messages from files that were not successfully compiled 321 | 322 | let uris = S.fromList $ fst <$> asts 323 | other = filter ((`S.notMember` uris) . fst) . M.toList 324 | 325 | forM_ (other warns) $ \(uri', msgs) -> do 326 | let updateEntry e = e { warningMessages = msgs } 327 | modify $ \s -> s { modules = modifyEntry updateEntry uri' s.modules } 328 | 329 | forM_ (other errors) $ \(uri', msgs) -> do 330 | let updateEntry e = e { errorMessages = msgs } 331 | modify $ \s -> s { modules = modifyEntry updateEntry uri' s.modules } 332 | 333 | -- | Fetches the number of module entries in the store in a monadic way. 334 | getModuleCount :: (MonadState IndexStore m) => m Int 335 | getModuleCount = gets storedModuleCount 336 | 337 | -- | Fetches a module entry in the store in a monadic way. 338 | getModule :: (MonadState IndexStore m) => J.NormalizedUri -> MaybeT m ModuleStoreEntry 339 | getModule uri = liftMaybe =<< gets (storedModule uri) 340 | 341 | -- | Fetches the module entries in the store as a list in a monadic way. 342 | getModuleList :: (MonadState IndexStore m) => m [(J.NormalizedUri, ModuleStoreEntry)] 343 | getModuleList = gets storedModules 344 | 345 | -- | Fetches the AST for a given URI in the store in a monadic way. 346 | getModuleAST :: (MonadState IndexStore m) => J.NormalizedUri -> MaybeT m ModuleAST 347 | getModuleAST uri = (liftMaybe . (.moduleAST)) =<< getModule uri 348 | -------------------------------------------------------------------------------- /src/Curry/LanguageServer/Index/Symbol.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoFieldSelectors, OverloadedStrings, OverloadedRecordDot #-} 2 | module Curry.LanguageServer.Index.Symbol 3 | ( SymbolKind (..) 4 | , Symbol (..) 5 | , symbolParentIdent 6 | , symbolIsFromCurrySource 7 | ) where 8 | 9 | import Control.Lens ((^.)) 10 | import Data.Default (Default (..)) 11 | import Data.Maybe (fromMaybe) 12 | import qualified Data.Text as T 13 | import qualified Language.LSP.Protocol.Types as J 14 | import qualified Language.LSP.Protocol.Lens as J 15 | 16 | -- | The 'kind' of the symbol in the LSP sense. 17 | data SymbolKind = ValueFunction 18 | | ValueConstructor 19 | | Module 20 | | TypeData 21 | | TypeNew 22 | | TypeClass 23 | | TypeAlias 24 | | TypeVar 25 | | Unknown 26 | deriving (Show, Eq) 27 | 28 | -- | A module, type or value. If it's a type, the 'printed type' will be the printed kind. 29 | data Symbol = Symbol 30 | { kind :: SymbolKind 31 | , qualIdent :: T.Text 32 | , ident :: T.Text 33 | , printedType :: Maybe T.Text 34 | , printedArgumentTypes :: [T.Text] 35 | , printedResultType :: Maybe T.Text 36 | , arrowArity :: Maybe Int 37 | , constructors :: [T.Text] 38 | , location :: Maybe J.Location 39 | } 40 | deriving (Show, Eq) 41 | 42 | instance Default Symbol where 43 | def = Symbol 44 | { kind = Unknown 45 | , qualIdent = "" 46 | , ident = "" 47 | , printedType = Nothing 48 | , printedArgumentTypes = [] 49 | , printedResultType = Nothing 50 | , arrowArity = Nothing 51 | , constructors = [] 52 | , location = Nothing 53 | } 54 | 55 | symbolParentIdent :: Symbol -> T.Text 56 | symbolParentIdent s = fromMaybe "" $ T.stripSuffix ("." <> s.ident) s.qualIdent 57 | 58 | symbolIsFromCurrySource :: Symbol -> Bool 59 | symbolIsFromCurrySource s = maybe False ((".curry" `T.isSuffixOf`) . J.getUri . (^. J.uri)) s.location 60 | -------------------------------------------------------------------------------- /src/Curry/LanguageServer/Monad.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances, NoFieldSelectors, OverloadedRecordDot, MultiParamTypeClasses, OverloadedStrings #-} 2 | module Curry.LanguageServer.Monad 3 | ( LSState (..) 4 | , newLSStateVar 5 | , LSM 6 | , getLSState, putLSState, modifyLSState 7 | , getStore, putStore, modifyStore 8 | , triggerDebouncer 9 | , markModuleDirty, scheduleModuleHandler 10 | , runLSM 11 | ) where 12 | 13 | import qualified Curry.LanguageServer.Config as CFG 14 | import qualified Curry.LanguageServer.Index.Store as I 15 | import Control.Concurrent.MVar (MVar, newMVar, readMVar, putMVar, modifyMVar) 16 | import Control.Monad.IO.Unlift (askRunInIO) 17 | import Control.Monad.Reader (ReaderT, runReaderT, ask) 18 | import Control.Monad.State.Class (MonadState(..)) 19 | import Control.Monad.Trans (lift, liftIO) 20 | import Curry.LanguageServer.Utils.Concurrent (Debouncer, debounce) 21 | import Data.Default (Default(..)) 22 | import Data.Maybe (fromMaybe) 23 | import qualified Data.Map as M 24 | import Language.LSP.Server (LspT, LanguageContextEnv, runLspT) 25 | import qualified Language.LSP.Protocol.Types as J 26 | 27 | data DirtyModuleHandlers = DirtyModuleHandlers { recompileHandler :: IO () 28 | , auxiliaryHandler :: IO () 29 | } 30 | 31 | instance Default DirtyModuleHandlers where 32 | def = DirtyModuleHandlers 33 | { recompileHandler = return () 34 | , auxiliaryHandler = return () 35 | } 36 | 37 | -- The language server's state, e.g. holding loaded/compiled modules. 38 | data LSState = LSState { indexStore :: I.IndexStore 39 | , dirtyModuleHandlers :: M.Map J.Uri DirtyModuleHandlers 40 | , debouncer :: Debouncer (IO ()) IO 41 | } 42 | 43 | newLSState :: IO LSState 44 | newLSState = do 45 | -- TODO: Make this delay configurable, e.g. through a config option 46 | let delayMs = 500 47 | debouncer <- debounce (delayMs * 1000) id 48 | return LSState 49 | { indexStore = def 50 | , dirtyModuleHandlers = M.empty 51 | , debouncer = debouncer 52 | } 53 | 54 | newLSStateVar :: IO (MVar LSState) 55 | newLSStateVar = newMVar =<< newLSState 56 | 57 | -- | The monad holding (thread-safe) state used by the language server. 58 | type LSM = LspT CFG.Config (ReaderT (MVar LSState) IO) 59 | 60 | instance MonadState I.IndexStore LSM where 61 | get = getStore 62 | put = putStore 63 | 64 | -- | Fetches the language server's state inside the LSM monad 65 | getLSState :: LSM LSState 66 | getLSState = do 67 | stVar <- lift ask 68 | liftIO $ readMVar stVar 69 | 70 | -- | Replaces the language server's state inside the LSM monad 71 | putLSState :: LSState -> LSM () 72 | putLSState s = do 73 | stVar <- lift ask 74 | liftIO $ putMVar stVar s 75 | 76 | -- | Updates the language server's state inside the LSM monad 77 | modifyLSState :: (LSState -> LSState) -> LSM () 78 | modifyLSState m = do 79 | stVar <- lift ask 80 | liftIO $ modifyMVar stVar $ \s -> return (m s, ()) 81 | 82 | -- | Fetches the index store holding compiled modules. 83 | getStore :: LSM I.IndexStore 84 | getStore = (.indexStore) <$> getLSState 85 | 86 | -- | Replaces the index store holding compiled modules. 87 | putStore :: I.IndexStore -> LSM () 88 | putStore i = modifyLSState $ \s -> s { indexStore = i } 89 | 90 | -- | Updates the index store holding compiled modules. 91 | modifyStore :: (I.IndexStore -> I.IndexStore) -> LSM () 92 | modifyStore m = modifyLSState $ \s -> s { indexStore = m s.indexStore } 93 | 94 | -- | Updates the dirty module handlers for a module. 95 | updateDirtyModuleHandlers :: J.Uri -> (DirtyModuleHandlers -> DirtyModuleHandlers) -> LSM () 96 | updateDirtyModuleHandlers uri f = modifyLSState $ \s -> s { dirtyModuleHandlers = M.alter (Just . f . fromMaybe def) uri s.dirtyModuleHandlers } 97 | 98 | -- | Runs all dirty module handlers. 99 | runDirtyModuleHandlers :: LSM () 100 | runDirtyModuleHandlers = do 101 | hs <- (.dirtyModuleHandlers) <$> getLSState 102 | liftIO $ M.foldl' (>>) (return ()) $ M.map (\dmh -> dmh.recompileHandler >> dmh.auxiliaryHandler) hs 103 | 104 | -- | Clears all dirty module handlers. 105 | clearDirtyModuleHandlers :: LSM () 106 | clearDirtyModuleHandlers = modifyLSState $ \s -> s { dirtyModuleHandlers = M.empty } 107 | 108 | -- | Triggers the debouncer that (eventually) executes and removes all dirty module handlers. 109 | triggerDebouncer :: LSM () 110 | triggerDebouncer = do 111 | (db, _) <- (.debouncer) <$> getLSState 112 | runInIO <- askRunInIO 113 | liftIO $ db $ runInIO $ do 114 | runDirtyModuleHandlers 115 | clearDirtyModuleHandlers 116 | 117 | -- | Marks a module as dirty (= edited, but not compiled yet) and replaces the recompilation handler with the given handler. 118 | markModuleDirty :: J.Uri -> LSM () -> LSM () 119 | markModuleDirty uri h = do 120 | runInIO <- askRunInIO 121 | updateDirtyModuleHandlers uri $ \dmh -> dmh { recompileHandler = runInIO h } 122 | triggerDebouncer 123 | 124 | -- | Adds a handler that either executes directly if the module is clean (= compiled, unedited) or defers its execution to the next compilation. 125 | scheduleModuleHandler :: J.Uri -> LSM () -> LSM () 126 | scheduleModuleHandler uri h = do 127 | hs <- (.dirtyModuleHandlers) <$> getLSState 128 | if M.member uri hs then do 129 | -- Module is dirty (edited since the last compilation), defer execution by attaching it as an auxiliary handler 130 | runInIO <- askRunInIO 131 | updateDirtyModuleHandlers uri $ \dmh -> dmh { auxiliaryHandler = dmh.auxiliaryHandler >> runInIO h } 132 | triggerDebouncer 133 | else do 134 | -- Module is clean (unedited since the last compilation), execute directly 135 | h 136 | 137 | -- | Runs the language server's state monad. 138 | runLSM :: LSM a -> MVar LSState -> LanguageContextEnv CFG.Config -> IO a 139 | runLSM lsm stVar cfg = runReaderT (runLspT cfg lsm) stVar 140 | -------------------------------------------------------------------------------- /src/Curry/LanguageServer/Utils/Concurrent.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase #-} 2 | module Curry.LanguageServer.Utils.Concurrent 3 | ( Debouncer 4 | , ConstDebouncer 5 | , debounce 6 | , debounceConst 7 | ) where 8 | 9 | import Control.Concurrent (threadDelay) 10 | import Control.Concurrent.Async (async, race, cancel) 11 | import Control.Concurrent.Chan (newChan, readChan, writeChan) 12 | import Control.Monad (forever) 13 | import Control.Monad.Fix (fix) 14 | import Control.Monad.IO.Class (MonadIO (liftIO)) 15 | import Control.Monad.IO.Unlift (MonadUnliftIO, askRunInIO) 16 | import Curry.LanguageServer.Utils.General ((<.$>)) 17 | 18 | type Debouncer a n = (a -> n (), n ()) 19 | type ConstDebouncer n = (n (), n ()) 20 | 21 | -- | A simple debouncer that fires when n microseconds have passed since the last call. 22 | -- Source: https://www.reddit.com/r/haskell/comments/ky1llf/concurrent_programming_puzzle_debouncing_events/gjmpbqg 23 | debounce :: (MonadIO m, MonadUnliftIO m, MonadIO n) => Int -> (a -> m ()) -> m (Debouncer a n) 24 | debounce delay action = do 25 | chan <- liftIO newChan 26 | runInIO <- askRunInIO 27 | 28 | worker <- liftIO $ async $ forever $ do 29 | x0 <- readChan chan 30 | 31 | -- Wait until no more entries arrive for 'delay' microseconds, then fire with the last entry 32 | flip fix x0 $ \loop x -> do 33 | race (readChan chan) (threadDelay delay) >>= \case 34 | Left x' -> loop x' 35 | Right () -> runInIO $ action x 36 | 37 | let debounced = liftIO . writeChan chan 38 | canceller = liftIO $ cancel worker 39 | return (debounced, canceller) 40 | 41 | -- | Debounces an action without parameters. 42 | debounceConst :: (MonadIO m, MonadUnliftIO m, MonadIO n) => Int -> m () -> m (ConstDebouncer n) 43 | debounceConst delay action = ($ ()) <.$> debounce delay (const action) 44 | -------------------------------------------------------------------------------- /src/Curry/LanguageServer/Utils/Convert.hs: -------------------------------------------------------------------------------- 1 | -- | Convert between Curry Compiler and language server structures 2 | {-# LANGUAGE RecordWildCards, ViewPatterns, OverloadedStrings, FlexibleInstances, UndecidableInstances #-} 3 | module Curry.LanguageServer.Utils.Convert 4 | ( curryMsg2Diagnostic 5 | , curryPos2Pos 6 | , curryPos2Uri 7 | , curryPos2Location 8 | , curryPos2LocationLink 9 | , currySpan2Range 10 | , currySpan2Uri 11 | , currySpan2Location 12 | , currySpan2LocationLink 13 | , currySpans2LocationLink 14 | , currySpanInfo2Range 15 | , currySpanInfo2Uri 16 | , currySpanInfo2Location 17 | , currySpanInfo2LocationLink 18 | , currySpanInfos2LocationLink 19 | , curryTextEdit2TextEdit 20 | , curryTextEdit2TextDocumentEdit 21 | , curryTextEdit2WorkspaceEdit 22 | , curryQuickFix2CodeAction 23 | , setCurryPosUri 24 | , setCurrySpanUri 25 | , setCurrySpanInfoUri 26 | , ppToStringPrec 27 | , ppToTextPrec 28 | , ppToString 29 | , ppToText 30 | , ppTypeSchemeToText 31 | , ppPredTypeToText 32 | , HasDocumentSymbols (..) 33 | , HasWorkspaceSymbols (..) 34 | ) where 35 | 36 | -- Curry Compiler Libraries + Dependencies 37 | import qualified Curry.Base.Ident as CI 38 | import qualified Curry.Base.Message as CM 39 | import qualified Curry.Base.Position as CP 40 | import qualified Curry.Base.Pretty as CPP 41 | import qualified Curry.Base.Span as CSP 42 | import qualified Curry.Base.SpanInfo as CSPI 43 | import qualified Curry.Base.TextEdit as CTE 44 | import qualified Curry.Base.QuickFix as CQF 45 | import qualified Curry.Syntax as CS 46 | import qualified Curry.Frontend.Base.Types as CT 47 | import qualified Text.PrettyPrint as PP 48 | 49 | import Control.Monad.IO.Class (MonadIO (..)) 50 | import Control.Monad.Trans.Maybe (MaybeT (..)) 51 | import Curry.LanguageServer.Utils.General 52 | import Curry.LanguageServer.Utils.Uri (filePathToUri, uriToFilePath) 53 | import Data.Maybe (fromMaybe, listToMaybe) 54 | import qualified Data.Text as T 55 | import qualified Language.LSP.Protocol.Types as J 56 | 57 | -- Curry Compiler -> Language Server Protocol 58 | 59 | curryMsg2Diagnostic :: J.DiagnosticSeverity -> CM.Message -> J.Diagnostic 60 | curryMsg2Diagnostic s msg = J.Diagnostic range severity code codeDesc src text tags related dataValue 61 | where range = fromMaybe emptyRange $ currySpanInfo2Range $ CM.msgSpanInfo msg 62 | severity = Just s 63 | code = Nothing 64 | codeDesc = Nothing 65 | src = Nothing 66 | text = T.pack $ PP.render $ CM.msgTxt msg 67 | -- TODO: It would be better to have the frontend expose this as a flag/tag instead. 68 | tags | "Unused" `T.isPrefixOf` text || "Unreferenced" `T.isPrefixOf` text = Just [J.DiagnosticTag_Unnecessary] 69 | | otherwise = Just [] 70 | related = Nothing 71 | dataValue = Nothing 72 | 73 | curryPos2Pos :: CP.Position -> Maybe J.Position 74 | curryPos2Pos CP.NoPos = Nothing 75 | curryPos2Pos CP.Position {..} = Just $ J.Position (fromIntegral line - 1) (fromIntegral column - 1) 76 | 77 | curryPos2Uri :: MonadIO m => CP.Position -> MaybeT m J.Uri 78 | curryPos2Uri CP.NoPos = liftMaybe Nothing 79 | curryPos2Uri CP.Position {..} = filePathToUri file 80 | 81 | curryPos2Location :: MonadIO m => CP.Position -> MaybeT m J.Location 82 | curryPos2Location cp = do 83 | p <- liftMaybe $ curryPos2Pos cp 84 | uri <- curryPos2Uri cp 85 | return $ J.Location uri $ pointRange p 86 | 87 | curryPos2LocationLink :: MonadIO m => CP.Position -> MaybeT m J.LocationLink 88 | curryPos2LocationLink cp = do 89 | p <- liftMaybe $ curryPos2Pos cp 90 | uri <- curryPos2Uri cp 91 | let range = pointRange p 92 | return $ J.LocationLink Nothing uri range range 93 | 94 | currySpan2Range :: CSP.Span -> Maybe J.Range 95 | currySpan2Range CSP.NoSpan = Nothing 96 | currySpan2Range CSP.Span {..} = do 97 | s <- curryPos2Pos start 98 | J.Position el ec <- curryPos2Pos end 99 | return $ J.Range s $ J.Position el (ec + 1) 100 | 101 | currySpan2Uri :: MonadIO m => CSP.Span -> MaybeT m J.Uri 102 | currySpan2Uri CSP.NoSpan = liftMaybe Nothing 103 | currySpan2Uri CSP.Span {..} = curryPos2Uri start 104 | 105 | currySpan2Location :: MonadIO m => CSP.Span -> MaybeT m J.Location 106 | currySpan2Location CSP.NoSpan = liftMaybe Nothing 107 | currySpan2Location spn = do 108 | range <- liftMaybe $ currySpan2Range spn 109 | uri <- currySpan2Uri spn 110 | return $ J.Location uri range 111 | 112 | currySpan2LocationLink :: MonadIO m => CSP.Span -> MaybeT m J.LocationLink 113 | currySpan2LocationLink CSP.NoSpan = liftMaybe Nothing 114 | currySpan2LocationLink spn = do 115 | range <- liftMaybe $ currySpan2Range spn 116 | uri <- currySpan2Uri spn 117 | return $ J.LocationLink Nothing uri range range 118 | 119 | currySpans2LocationLink :: MonadIO m => CSP.Span -> CSP.Span -> MaybeT m J.LocationLink 120 | currySpans2LocationLink CSP.NoSpan destSpan = currySpan2LocationLink destSpan 121 | currySpans2LocationLink _ CSP.NoSpan = liftMaybe Nothing 122 | currySpans2LocationLink srcSpan destSpan = do 123 | srcRange <- liftMaybe $ currySpan2Range srcSpan 124 | destRange <- liftMaybe $ currySpan2Range destSpan 125 | uri <- currySpan2Uri destSpan 126 | return $ J.LocationLink (Just srcRange) uri destRange destRange 127 | 128 | currySpanInfo2Range :: CSPI.HasSpanInfo a => a -> Maybe J.Range 129 | currySpanInfo2Range (CSPI.getSpanInfo -> CSPI.SpanInfo {..}) = currySpan2Range srcSpan 130 | currySpanInfo2Range _ = Nothing 131 | 132 | currySpanInfo2Uri :: MonadIO m => CSPI.HasSpanInfo a => a -> MaybeT m J.Uri 133 | currySpanInfo2Uri (CSPI.getSpanInfo -> CSPI.SpanInfo {..}) = currySpan2Uri srcSpan 134 | currySpanInfo2Uri _ = liftMaybe Nothing 135 | 136 | currySpanInfo2Location :: MonadIO m => CSPI.HasSpanInfo a => a -> MaybeT m J.Location 137 | currySpanInfo2Location (CSPI.getSpanInfo -> CSPI.SpanInfo {..}) = currySpan2Location srcSpan 138 | currySpanInfo2Location _ = liftMaybe Nothing 139 | 140 | currySpanInfo2LocationLink :: MonadIO m => CSPI.HasSpanInfo a => a -> MaybeT m J.LocationLink 141 | currySpanInfo2LocationLink (CSPI.getSpanInfo -> CSPI.SpanInfo {..}) = currySpan2LocationLink srcSpan 142 | currySpanInfo2LocationLink _ = liftMaybe Nothing 143 | 144 | currySpanInfos2LocationLink :: MonadIO m => CSPI.HasSpanInfo a => a -> CSPI.SpanInfo -> MaybeT m J.LocationLink 145 | currySpanInfos2LocationLink (CSPI.getSpanInfo -> CSPI.NoSpanInfo) spi = currySpanInfo2LocationLink spi 146 | currySpanInfos2LocationLink (CSPI.getSpanInfo -> CSPI.SpanInfo{srcSpan=srcSpan}) (CSPI.getSpanInfo -> CSPI.SpanInfo {srcSpan=destSpan}) = currySpans2LocationLink srcSpan destSpan 147 | currySpanInfos2LocationLink _ _ = liftMaybe Nothing 148 | 149 | curryTextEdit2TextEdit :: MonadIO m => CTE.TextEdit -> MaybeT m J.TextEdit 150 | curryTextEdit2TextEdit (CTE.TextEdit s e t) = do 151 | s' <- liftMaybe $ curryPos2Pos s 152 | e' <- liftMaybe $ curryPos2Pos e 153 | let range = J.Range s' e' 154 | return $ J.TextEdit range (T.pack t) 155 | 156 | curryTextEdit2TextDocumentEdit :: MonadIO m => CTE.TextEdit -> MaybeT m J.TextDocumentEdit 157 | curryTextEdit2TextDocumentEdit e = do 158 | uri <- curryPos2Uri $ CTE.editStart e 159 | let doc = J.OptionalVersionedTextDocumentIdentifier uri $ J.InL 0 160 | tedit <- curryTextEdit2TextEdit e 161 | return $ J.TextDocumentEdit doc [J.InL tedit] 162 | 163 | curryTextEdit2WorkspaceEdit :: MonadIO m => CTE.TextEdit -> MaybeT m J.WorkspaceEdit 164 | curryTextEdit2WorkspaceEdit e = do 165 | docEdit <- curryTextEdit2TextDocumentEdit e 166 | return $ J.WorkspaceEdit Nothing (Just [J.InL docEdit]) Nothing 167 | 168 | curryQuickFix2CodeAction :: MonadIO m => CQF.QuickFix -> [J.Diagnostic] -> MaybeT m J.CodeAction 169 | curryQuickFix2CodeAction (CQF.QuickFix e desc) diags = do 170 | wedit <- curryTextEdit2WorkspaceEdit e 171 | return $ J.CodeAction (T.pack desc) (Just kind) (Just diags) Nothing Nothing (Just wedit) Nothing Nothing 172 | where kind = J.CodeActionKind_QuickFix 173 | 174 | setCurryPosUri :: CP.HasPosition a => J.Uri -> a -> Maybe a 175 | setCurryPosUri uri x@(CP.getPosition -> p@(CP.Position {})) = do 176 | fp <- uriToFilePath uri 177 | return $ CP.setPosition p { CP.file = fp } x 178 | setCurryPosUri _ x = Just x 179 | 180 | setCurrySpanUri :: J.Uri -> CSP.Span -> Maybe CSP.Span 181 | setCurrySpanUri uri CSP.Span {..} = do 182 | fp <- uriToFilePath uri 183 | p1 <- setCurryPosUri uri start 184 | p2 <- setCurryPosUri uri end 185 | return $ CSP.Span fp p1 p2 186 | setCurrySpanUri _ CSP.NoSpan = Just CSP.NoSpan 187 | 188 | setCurrySpanInfoUri :: CSPI.HasSpanInfo a => J.Uri -> a -> Maybe a 189 | setCurrySpanInfoUri uri x@(CSPI.getSpanInfo -> spi@CSPI.SpanInfo {..}) = do 190 | spn <- setCurrySpanUri uri srcSpan 191 | return $ CSPI.setSpanInfo spi { CSPI.srcSpan = spn } x 192 | setCurrySpanInfoUri _ x = Just x 193 | 194 | ppToStringPrec :: CPP.Pretty p => Int -> p -> String 195 | ppToStringPrec p = PP.render . CPP.pPrintPrec p 196 | 197 | ppToTextPrec :: CPP.Pretty p => Int -> p -> T.Text 198 | ppToTextPrec p = T.pack . ppToStringPrec p 199 | 200 | ppToString :: CPP.Pretty p => p -> String 201 | ppToString = PP.render . CPP.pPrint 202 | 203 | ppToText :: CPP.Pretty p => p -> T.Text 204 | ppToText = T.pack . ppToString 205 | 206 | ppTypeSchemeToText :: CI.ModuleIdent -> CT.TypeScheme -> T.Text 207 | ppTypeSchemeToText mid = T.pack . PP.render . CT.ppTypeScheme mid 208 | 209 | ppPredTypeToText :: CI.ModuleIdent -> CT.PredType -> T.Text 210 | ppPredTypeToText mid = T.pack . PP.render . CT.ppPredType mid 211 | 212 | ppPatternToName :: CS.Pattern a -> T.Text 213 | ppPatternToName pat = case pat of 214 | CS.VariablePattern _ _ ident -> ppToText ident 215 | CS.InfixPattern _ _ _ ident _ -> ppToText ident 216 | CS.RecordPattern _ _ ident _ -> ppToText ident 217 | CS.TuplePattern _ ps -> "(" <> (T.intercalate ", " $ ppPatternToName <$> ps) <> ")" 218 | CS.InfixFuncPattern _ _ _ ident _ -> ppToText ident 219 | _ -> "?" 220 | 221 | makeDocumentSymbol :: T.Text -> J.SymbolKind -> Maybe J.Range -> Maybe [J.DocumentSymbol] -> J.DocumentSymbol 222 | makeDocumentSymbol n k r cs = J.DocumentSymbol n Nothing k Nothing Nothing r' r' cs 223 | where r' = fromMaybe emptyRange r 224 | 225 | class HasDocumentSymbols s where 226 | documentSymbols :: s -> [J.DocumentSymbol] 227 | 228 | instance HasDocumentSymbols (CS.Module a) where 229 | documentSymbols (CS.Module spi _ _ ident _ _ decls) = [makeDocumentSymbol name symKind range $ Just childs] 230 | where name = ppToText ident 231 | symKind = J.SymbolKind_Module 232 | range = currySpanInfo2Range spi 233 | childs = documentSymbols =<< decls 234 | 235 | instance HasDocumentSymbols (CS.Decl a) where 236 | documentSymbols decl = case decl of 237 | CS.InfixDecl _ _ _ idents -> [makeDocumentSymbol name symKind range Nothing] 238 | where name = maybe "" ppToText $ listToMaybe idents 239 | symKind = J.SymbolKind_Operator 240 | CS.DataDecl _ ident _ cs _ -> [makeDocumentSymbol name symKind range $ Just childs] 241 | where name = ppToText ident 242 | symKind = if length cs > 1 then J.SymbolKind_Enum 243 | else J.SymbolKind_Struct 244 | childs = documentSymbols =<< cs 245 | CS.NewtypeDecl _ ident _ c _ -> [makeDocumentSymbol name symKind range $ Just childs] 246 | where name = ppToText ident 247 | symKind = J.SymbolKind_Struct 248 | childs = documentSymbols c 249 | CS.ExternalDataDecl _ ident _ -> [makeDocumentSymbol name symKind range Nothing] 250 | where name = ppToText ident 251 | symKind = J.SymbolKind_Struct 252 | CS.FunctionDecl _ _ ident eqs -> [makeDocumentSymbol name symKind range $ Just childs] 253 | where name = ppToText ident 254 | symKind = if eqsArity eqs > 0 then J.SymbolKind_Function 255 | else J.SymbolKind_Constant 256 | childs = documentSymbols =<< eqs 257 | CS.TypeDecl _ ident _ _ -> [makeDocumentSymbol name symKind range Nothing] 258 | where name = ppToText ident 259 | symKind = J.SymbolKind_Interface 260 | CS.ExternalDecl _ vars -> documentSymbols =<< vars 261 | CS.FreeDecl _ vars -> documentSymbols =<< vars 262 | CS.PatternDecl _ pat rhs -> [makeDocumentSymbol name symKind range $ Just childs] 263 | where name = ppPatternToName pat 264 | symKind = if patArity pat > 0 then J.SymbolKind_Function 265 | else J.SymbolKind_Constant 266 | childs = documentSymbols rhs 267 | CS.ClassDecl _ _ _ ident _ _ decls -> [makeDocumentSymbol name symKind range $ Just childs] 268 | where name = ppToText ident 269 | symKind = J.SymbolKind_Interface 270 | childs = documentSymbols =<< decls 271 | CS.InstanceDecl _ _ _ qident t decls -> [makeDocumentSymbol name symKind range $ Just childs] 272 | where name = ppToText qident <> " (" <> (T.pack $ PP.render $ CPP.pPrintPrec 2 t) <> ")" 273 | symKind = J.SymbolKind_Namespace 274 | childs = documentSymbols =<< decls 275 | _ -> [] 276 | where lhsArity :: CS.Lhs a -> Int 277 | lhsArity lhs = case lhs of 278 | CS.FunLhs _ _ pats -> length pats 279 | CS.OpLhs _ _ _ _ -> 2 280 | CS.ApLhs _ _ pats -> length pats 281 | patArity :: CS.Pattern a -> Int 282 | patArity pat = case pat of 283 | CS.FunctionPattern _ _ _ ps -> length ps 284 | _ -> 0 285 | eqsArity :: [CS.Equation a] -> Int 286 | eqsArity eqs = maybe 1 (\(CS.Equation _ _ lhs _) -> lhsArity lhs) $ listToMaybe eqs 287 | range = currySpanInfo2Range $ CSPI.getSpanInfo decl 288 | 289 | instance HasDocumentSymbols (CS.Var a) where 290 | documentSymbols (CS.Var _ ident) = [makeDocumentSymbol (ppToText ident) J.SymbolKind_Variable range Nothing] 291 | where range = currySpanInfo2Range $ CSPI.getSpanInfo ident 292 | 293 | instance HasDocumentSymbols CS.ConstrDecl where 294 | documentSymbols decl = case decl of 295 | CS.ConstrDecl _ ident _ -> [makeDocumentSymbol (ppToText ident) J.SymbolKind_EnumMember range Nothing] 296 | CS.ConOpDecl _ _ ident _ -> [makeDocumentSymbol (ppToText ident) J.SymbolKind_Operator range Nothing] 297 | CS.RecordDecl _ ident _ -> [makeDocumentSymbol (ppToText ident) J.SymbolKind_EnumMember range Nothing] 298 | where range = currySpanInfo2Range $ CSPI.getSpanInfo decl 299 | 300 | instance HasDocumentSymbols (CS.Equation a) where 301 | documentSymbols (CS.Equation _ _ _ rhs) = documentSymbols rhs 302 | 303 | instance HasDocumentSymbols (CS.Rhs a) where 304 | documentSymbols rhs = case rhs of 305 | CS.SimpleRhs _ _ e decls -> documentSymbols e ++ (documentSymbols =<< decls) 306 | CS.GuardedRhs _ _ conds decls -> (documentSymbols =<< conds) ++ (documentSymbols =<< decls) 307 | 308 | instance HasDocumentSymbols (CS.CondExpr a) where 309 | documentSymbols (CS.CondExpr _ e1 e2) = documentSymbols e1 ++ documentSymbols e2 310 | 311 | instance HasDocumentSymbols (CS.Expression a) where 312 | documentSymbols e = case e of 313 | CS.Paren _ e' -> documentSymbols e' 314 | CS.Typed _ e' _ -> documentSymbols e' 315 | CS.Record _ _ _ fields -> fieldSymbols =<< fields 316 | CS.RecordUpdate _ e' fields -> documentSymbols e' ++ (fieldSymbols =<< fields) 317 | CS.Tuple _ entries -> documentSymbols =<< entries 318 | CS.List _ _ entries -> documentSymbols =<< entries 319 | CS.ListCompr _ e' stmts -> documentSymbols e' ++ (documentSymbols =<< stmts) 320 | CS.EnumFrom _ e' -> documentSymbols e' 321 | CS.EnumFromThen _ e1 e2 -> documentSymbols e1 ++ documentSymbols e2 322 | CS.EnumFromThenTo _ e1 e2 e3 -> documentSymbols e1 ++ documentSymbols e2 ++ documentSymbols e3 323 | CS.UnaryMinus _ e' -> documentSymbols e' 324 | CS.Apply _ e1 e2 -> documentSymbols e1 ++ documentSymbols e2 325 | CS.InfixApply _ e1 _ e2 -> documentSymbols e1 ++ documentSymbols e2 326 | CS.LeftSection _ e' _ -> documentSymbols e' 327 | CS.RightSection _ _ e' -> documentSymbols e' 328 | CS.Lambda _ _ e' -> documentSymbols e' 329 | CS.Let _ _ decls e' -> (documentSymbols =<< decls) ++ documentSymbols e' 330 | CS.Do _ _ stmts e' -> (documentSymbols =<< stmts) ++ documentSymbols e' 331 | CS.IfThenElse _ e1 e2 e3 -> documentSymbols e1 ++ documentSymbols e2 ++ documentSymbols e3 332 | CS.Case _ _ _ e' alts -> documentSymbols e' ++ (documentSymbols =<< alts) 333 | _ -> [] 334 | where fieldSymbols (CS.Field _ _ e') = documentSymbols e' 335 | 336 | instance HasDocumentSymbols (CS.Statement a) where 337 | documentSymbols stmt = case stmt of 338 | CS.StmtExpr _ e -> documentSymbols e 339 | CS.StmtDecl _ _ decls -> documentSymbols =<< decls 340 | CS.StmtBind _ _ e -> documentSymbols e 341 | 342 | instance HasDocumentSymbols (CS.Alt a) where 343 | documentSymbols (CS.Alt _ _ rhs) = documentSymbols rhs 344 | 345 | instance HasDocumentSymbols CS.NewConstrDecl where 346 | documentSymbols decl = case decl of 347 | CS.NewConstrDecl spi ident _ -> [makeDocumentSymbol (ppToText ident) symKind (currySpanInfo2Range spi) Nothing] 348 | CS.NewRecordDecl spi ident _ -> [makeDocumentSymbol (ppToText ident) symKind (currySpanInfo2Range spi) Nothing] 349 | where symKind = J.SymbolKind_EnumMember 350 | 351 | class HasWorkspaceSymbols s where 352 | workspaceSymbols :: s -> IO [J.SymbolInformation] 353 | 354 | instance (HasDocumentSymbols s, CSPI.HasSpanInfo s) => HasWorkspaceSymbols s where 355 | workspaceSymbols s = do 356 | loc <- runMaybeT $ currySpanInfo2Location $ CSPI.getSpanInfo s 357 | let documentSymbolToInformations :: J.DocumentSymbol -> [J.SymbolInformation] 358 | documentSymbolToInformations (J.DocumentSymbol n _ k ts d _ _ cs) = ((\l -> J.SymbolInformation n k ts Nothing d l) <$> loc) `maybeCons` cis 359 | where cs' = maybe [] id cs 360 | cis = documentSymbolToInformations =<< cs' 361 | return $ documentSymbolToInformations =<< documentSymbols s 362 | 363 | -- Language Server Protocol -> Curry Compiler 364 | 365 | -- TODO 366 | -------------------------------------------------------------------------------- /src/Curry/LanguageServer/Utils/General.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FunctionalDependencies, FlexibleInstances, MultiWayIf, NoFieldSelectors, OverloadedRecordDot #-} 2 | -- | General utilities. 3 | module Curry.LanguageServer.Utils.General 4 | ( lastSafe 5 | , rangeElem, rangeOverlaps 6 | , nth 7 | , pair 8 | , dup 9 | , wordAtIndex, wordAtPos 10 | , wordsWithSpaceCount 11 | , pointRange, emptyRange 12 | , maybeCons 13 | , WalkConfiguration (..) 14 | , walkFiles 15 | , walkFilesIgnoring 16 | , walkFilesWith 17 | , liftMaybe 18 | , slipr3, slipr4 19 | , (<.$>), (<$.>) 20 | , joinFst, joinSnd 21 | , removeSingle 22 | , nothingIfNull 23 | , replaceString 24 | , snapToLastTokenStart 25 | , snapToLastTokenEnd 26 | , Insertable (..) 27 | , ConstMap (..) 28 | , insertIntoTrieWith 29 | , insertAllIntoTrieWith 30 | , groupIntoMapBy 31 | , groupIntoMapByM 32 | , fst3, snd3, thd3 33 | , tripleToPair 34 | , filterF 35 | , dropLast 36 | ) where 37 | 38 | import Control.Monad (join, filterM) 39 | import Control.Monad.IO.Class (MonadIO (..)) 40 | import Control.Monad.Trans (lift) 41 | import Control.Monad.Trans.Maybe (MaybeT (..)) 42 | import qualified Data.ByteString as B 43 | import Data.Bifunctor (first, second) 44 | import Data.Char (isSpace) 45 | import Data.Default (Default (..)) 46 | import qualified Data.List as L 47 | import Data.Maybe (fromMaybe) 48 | import Data.Foldable (foldrM) 49 | import qualified Data.Text as T 50 | import qualified Data.Trie as TR 51 | import qualified Data.Map as M 52 | import qualified Data.Set as S 53 | import qualified Language.LSP.Protocol.Types as J 54 | import System.FilePath 55 | import System.IO.Unsafe (unsafeInterleaveIO) 56 | import System.Directory 57 | 58 | -- | Safely fetches the last element of the given list. 59 | lastSafe :: [a] -> Maybe a 60 | lastSafe xs | null xs = Nothing 61 | | otherwise = Just $ last xs 62 | 63 | -- | Tests whether a position is inside a given range. 64 | rangeElem :: J.Position -> J.Range -> Bool 65 | rangeElem (J.Position l c) range | l1 == l2 && l == l1 = c1 <= c && c <= c2 66 | | l == l1 = c1 <= c 67 | | l == l2 = c <= c2 68 | | otherwise = l1 <= l && l <= l2 69 | where (J.Range (J.Position l1 c1) (J.Position l2 c2)) = range 70 | 71 | -- | Tests whether two given ranges overlap. 72 | rangeOverlaps :: J.Range -> J.Range -> Bool 73 | rangeOverlaps r1@(J.Range p1 p2) r2@(J.Range p3 p4) = rangeElem p1 r2 74 | || rangeElem p2 r2 75 | || rangeElem p3 r1 76 | || rangeElem p4 r1 77 | 78 | -- | Safely fetches the nth entry. 79 | nth :: Integral n => n -> [a] -> Maybe a 80 | nth _ [] = Nothing 81 | nth n (x:xs) | n' == 0 = Just x 82 | | n' < 0 = Nothing 83 | | otherwise = nth (n' - 1) xs 84 | where n' = (fromIntegral n :: Int) 85 | 86 | -- | Creates a pair. Useful in conjunction with partial application. 87 | pair :: a -> b -> (a, b) 88 | pair x y = (x, y) 89 | 90 | -- | Duplicates. 91 | dup :: a -> (a, a) 92 | dup x = (x, x) 93 | 94 | -- | Finds the word at the given offset. 95 | wordAtIndex :: Integral n => n -> T.Text -> Maybe T.Text 96 | wordAtIndex n = wordAtIndex' n . wordsWithSpaceCount 97 | where wordAtIndex' :: Integral n => n -> [(n, T.Text)] -> Maybe T.Text 98 | wordAtIndex' _ [] = Nothing 99 | wordAtIndex' n' ((k, s):ss) | (n' - k) <= len = Just s 100 | | otherwise = wordAtIndex' (n' - len - k) ss 101 | where len = fromIntegral $ T.length s 102 | 103 | -- | Fetches the words with the list of spaces preceding them. 104 | wordsWithSpaceCount :: Integral n => T.Text -> [(n, T.Text)] 105 | wordsWithSpaceCount t | T.null t = [] 106 | | otherwise = (fromIntegral $ T.length s, w) : wordsWithSpaceCount t'' 107 | -- TODO: Implement using T.breakOnAll 108 | where s = T.takeWhile isSpace t 109 | t' = T.dropWhile isSpace t 110 | w = T.takeWhile (not . isSpace) t' 111 | t'' = T.dropWhile (not . isSpace) t' 112 | 113 | -- | Finds the word at a given position. 114 | wordAtPos :: J.Position -> T.Text -> Maybe T.Text 115 | wordAtPos (J.Position l c) = (T.strip <$>) . (wordAtIndex c =<<) . nth l . T.lines 116 | 117 | -- | The point range at the origin. 118 | emptyRange :: J.Range 119 | emptyRange = J.Range (J.Position 0 0) (J.Position 0 0) 120 | 121 | -- | A range that starts and ends at the given position. 122 | pointRange :: J.Position -> J.Range 123 | pointRange p = J.Range p p 124 | 125 | -- | Appends an element at the front if the optional value is present. 126 | maybeCons :: Maybe a -> [a] -> [a] 127 | maybeCons Nothing = id 128 | maybeCons (Just x) = (x:) 129 | 130 | -- | A filtering configuration for a file walk. 131 | data WalkConfiguration m a = WalkConfiguration 132 | { -- | Executed when entering a new directory. Fetches some directory-specific 133 | -- state for later use during filtering, e.g. an ignore file. Returning 134 | -- Nothing causes the walker to skip the the directory. 135 | onEnter :: FilePath -> m (Maybe a) 136 | -- | Tests whether a file or directory should be ignored using the state of 137 | -- the directory containing the path. 138 | , shouldIgnore :: a -> FilePath -> m Bool 139 | -- | Whether the walk should include directories. 140 | , includeDirectories :: Bool 141 | -- | Whether the walk should include files. 142 | , includeFiles :: Bool 143 | } 144 | 145 | instance (Default a, Monad m) => Default (WalkConfiguration m a) where 146 | def = WalkConfiguration 147 | { onEnter = const $ return $ Just def 148 | , shouldIgnore = const $ const $ return False 149 | , includeDirectories = False 150 | , includeFiles = True 151 | } 152 | 153 | -- | An empty walk configuration. 154 | emptyWalkConfiguration :: Monad m => WalkConfiguration m () 155 | emptyWalkConfiguration = def 156 | 157 | -- | Lists files in the directory recursively. 158 | walkFiles :: MonadIO m => FilePath -> m [FilePath] 159 | walkFiles = walkFilesWith emptyWalkConfiguration 160 | 161 | -- | Lists files in the directory recursively, ignoring files matching the given predicate. 162 | walkFilesIgnoring :: MonadIO m => (FilePath -> Bool) -> FilePath -> m [FilePath] 163 | walkFilesIgnoring ignore = walkFilesWith emptyWalkConfiguration 164 | { shouldIgnore = const $ return . ignore 165 | } 166 | 167 | -- | Lists files in the directory recursively with the given configuration. 168 | walkFilesWith :: MonadIO m => WalkConfiguration m a -> FilePath -> m [FilePath] 169 | walkFilesWith wc fp = (fromMaybe [] <$>) $ runMaybeT $ do 170 | isDirectory <- liftIO $ unsafeInterleaveIO $ doesDirectoryExist fp 171 | isFile <- liftIO $ unsafeInterleaveIO $ doesFileExist fp 172 | if | isDirectory -> do 173 | state <- MaybeT $ wc.onEnter fp 174 | contents <- liftIO $ listDirectory fp 175 | contents' <- map (fp ) <$> filterM ((not <$>) . lift . wc.shouldIgnore state) contents 176 | ([fp | wc.includeDirectories] ++) . join <$> mapM (lift . walkFilesWith wc) contents' 177 | | isFile -> return [fp | wc.includeFiles] 178 | | otherwise -> liftMaybe Nothing 179 | 180 | -- | Lifts a Maybe into a Maybe transformer. 181 | liftMaybe :: Monad m => Maybe a -> MaybeT m a 182 | liftMaybe = MaybeT . return 183 | 184 | -- | Moves the first parameter to the end. 185 | slipr3 :: (a -> b -> c -> d) -> b -> c -> a -> d 186 | slipr3 f y z x = f x y z 187 | 188 | -- | Moves the first parameter to the end. 189 | slipr4 :: (a -> b -> c -> d -> e) -> b -> c -> d -> a -> e 190 | slipr4 f y z w x = f x y z w 191 | 192 | -- | Maps over the first element of a tuple. 193 | (<.$>) :: Functor f => (a -> c) -> f (a, b) -> f (c, b) 194 | (<.$>) f = fmap $ first f 195 | 196 | -- | Maps over the second element of a tuple. 197 | (<$.>) :: Functor f => (b -> c) -> f (a, b) -> f (a, c) 198 | (<$.>) f = fmap $ second f 199 | 200 | joinFst :: Monad m => m (m a, b) -> m (a, b) 201 | joinFst m = do 202 | (mx, y) <- m 203 | x <- mx 204 | return (x, y) 205 | 206 | joinSnd :: Monad m => m (a, m b) -> m (a, b) 207 | joinSnd m = do 208 | (x, my) <- m 209 | y <- my 210 | return (x, y) 211 | 212 | -- | Removes a single element from the list (returning all possible solutions). 213 | removeSingle :: [a] -> [([a], a)] 214 | removeSingle [] = [] 215 | removeSingle (x:xs) = (xs, x) : (x:) <.$> removeSingle xs 216 | 217 | -- | Wraps a list into a Maybe that is Nothing if the list is empty. 218 | nothingIfNull :: [a] -> Maybe [a] 219 | nothingIfNull [] = Nothing 220 | nothingIfNull xs = Just xs 221 | 222 | replaceString :: String -> String -> String -> String 223 | replaceString n r = T.unpack . T.replace (T.pack n) (T.pack r) . T.pack 224 | 225 | -- | Moves the cursor back until the beginning of the last token. 226 | snapToLastTokenStart :: Integral n => String -> n -> n 227 | snapToLastTokenStart = snapBack $ dropWhile (not . isSpace) . dropWhile isSpace 228 | 229 | -- | Moves the cursor back until a non-whitespace character precedes it (i.e. past the end of the last token). 230 | snapToLastTokenEnd :: Integral n => String -> n -> n 231 | snapToLastTokenEnd = snapBack $ dropWhile isSpace 232 | 233 | snapBack :: Integral n => ([a] -> [a]) -> [a] -> n -> n 234 | snapBack f s n = fromIntegral $ length $ f $ reverse $ take (fromIntegral n) s 235 | 236 | class Insertable m a | m -> a where 237 | -- | Inserts a single entry. 238 | insert :: a -> m -> m 239 | insert x = insertAll [x] 240 | 241 | -- | Inserts multiple entries. 242 | insertAll :: Foldable t => t a -> m -> m 243 | insertAll = flip $ foldr insert 244 | 245 | instance Insertable (Maybe a) a where 246 | insert = const . Just 247 | 248 | instance Ord a => Insertable [a] a where 249 | insert = L.insert 250 | 251 | instance Ord k => Insertable (M.Map k v) (k, v) where 252 | insert = uncurry M.insert 253 | 254 | instance Ord a => Insertable (S.Set a) a where 255 | insert = S.insert 256 | 257 | instance Insertable (TR.Trie a) (B.ByteString, a) where 258 | insert = uncurry TR.insert 259 | 260 | -- | A map that 'pins' a key to a value once inserted. 261 | newtype ConstMap k v = ConstMap { ctmMap :: M.Map k v } 262 | 263 | instance Functor (ConstMap k) where 264 | fmap f (ConstMap m) = ConstMap $ fmap f m 265 | 266 | instance Foldable (ConstMap k) where 267 | foldr f x (ConstMap m) = foldr f x m 268 | 269 | instance Traversable (ConstMap k) where 270 | traverse f (ConstMap m) = ConstMap <$> traverse f m 271 | 272 | instance Ord k => Insertable (ConstMap k v) (k, v) where 273 | insert (k, v) (ConstMap m) = ConstMap $ M.insertWith (const id) k v m 274 | 275 | instance Ord k => Semigroup (ConstMap k v) where 276 | -- Note how ConstMap uses a 'flipped' (<>). This is analogous to how 277 | -- the insertion combiner also corresponds to a 'flipped' const. 278 | ConstMap m <> ConstMap m' = ConstMap $ M.union m' m 279 | 280 | instance Ord k => Monoid (ConstMap k v) where 281 | mempty = ConstMap M.empty 282 | 283 | -- | Inserts the given element into the trie using the combination function. 284 | -- The combination function takes the new value on the left and the old one on the right. 285 | insertIntoTrieWith :: (a -> a -> a) -> B.ByteString -> a -> TR.Trie a -> TR.Trie a 286 | insertIntoTrieWith f s x t | TR.member s t = TR.adjust (f x) s t 287 | | otherwise = TR.insert s x t 288 | 289 | -- | Inserts the given elements into the trie using the combination function. 290 | -- The combination function takes the new value on the left and the old one on the right. 291 | insertAllIntoTrieWith :: Foldable t => (a -> a -> a) -> t (B.ByteString, a) -> TR.Trie a -> TR.Trie a 292 | insertAllIntoTrieWith f = flip $ foldr (uncurry $ insertIntoTrieWith f) 293 | 294 | -- | Groups by key into a map. 295 | groupIntoMapBy :: (Foldable t, Ord k) => (a -> k) -> t a -> M.Map k [a] 296 | groupIntoMapBy f = foldr (\x -> M.insertWith (++) (f x) [x]) M.empty 297 | 298 | -- | Groups by key into a map monadically. 299 | groupIntoMapByM :: (Foldable t, Ord k, Monad m) => (a -> m k) -> t a -> m (M.Map k [a]) 300 | groupIntoMapByM f = foldrM (\x m -> (\y -> M.insertWith (++) y [x] m) <$> f x) M.empty 301 | 302 | fst3 :: (a, b, c) -> a 303 | fst3 (x, _, _) = x 304 | 305 | snd3 :: (a, b, c) -> b 306 | snd3 (_, y, _) = y 307 | 308 | thd3 :: (a, b, c) -> c 309 | thd3 (_, _, z) = z 310 | 311 | tripleToPair :: (a, b, c) -> (a, b) 312 | tripleToPair (x, y, _) = (x, y) 313 | 314 | -- | Filter over a foldable value. For [a], filterF = filter. 315 | filterF :: Foldable t => (a -> Bool) -> t a -> [a] 316 | filterF f = foldr (\x xs -> if f x then x : xs else xs) [] 317 | 318 | -- | Drops the last n items. 319 | dropLast :: Int -> [a] -> [a] 320 | dropLast n = reverse . drop n . reverse 321 | -------------------------------------------------------------------------------- /src/Curry/LanguageServer/Utils/Logging.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings, OverloadedRecordDot, FlexibleContexts #-} 2 | module Curry.LanguageServer.Utils.Logging 3 | ( logAt, showAt 4 | , errorM, warnM, infoM, debugM 5 | ) where 6 | 7 | import Colog.Core (Severity (..), WithSeverity (..), (<&)) 8 | import Control.Monad (when) 9 | import Curry.LanguageServer.Config (Config (..), LogLevel (..)) 10 | import qualified Data.Text as T 11 | import Language.LSP.Logging (logToLogMessage, logToShowMessage) 12 | import Language.LSP.Server (MonadLsp, getConfig) 13 | 14 | -- | Logs a message to the output console (window/logMessage). 15 | logAt :: MonadLsp Config m => Severity -> T.Text -> m () 16 | logAt sev msg = do 17 | cfg <- getConfig 18 | when (sev >= cfg.logLevel.severity) $ 19 | logToLogMessage <& WithSeverity msg sev 20 | 21 | -- | Presents a log message in a notification to the user (window/showMessage). 22 | showAt :: MonadLsp Config m => Severity -> T.Text -> m () 23 | showAt sev msg = logToShowMessage <& WithSeverity msg sev 24 | 25 | -- | Logs a message at the error level. This presents an error notification to the user. 26 | errorM :: MonadLsp Config m => T.Text -> m () 27 | errorM = showAt Error 28 | 29 | -- | Logs a message at the warning level. 30 | warnM :: MonadLsp Config m => T.Text -> m () 31 | warnM = logAt Warning 32 | 33 | -- | Logs a message at the info level. 34 | infoM :: MonadLsp Config m => T.Text -> m () 35 | infoM = logAt Info 36 | 37 | -- | Logs a message at the debug level. 38 | debugM :: MonadLsp Config m => T.Text -> m () 39 | -- TODO: Remove [Debug] prefix once https://github.com/microsoft/vscode-languageserver-node/issues/1255 40 | -- is resolved and upstreamed to haskell/lsp 41 | debugM t = logAt Debug $ "[Debug] " <> t 42 | -------------------------------------------------------------------------------- /src/Curry/LanguageServer/Utils/Lookup.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, NoFieldSelectors, OverloadedRecordDot, ViewPatterns #-} 2 | -- | Position lookup in the AST. 3 | module Curry.LanguageServer.Utils.Lookup 4 | ( findQualIdentAtPos 5 | , findExprIdentAtPos 6 | , findModuleIdentAtPos 7 | , findTypeAtPos 8 | , findScopeAtPos 9 | , showScope 10 | , Scope 11 | ) where 12 | 13 | -- Curry Compiler Libraries + Dependencies 14 | import qualified Curry.Base.Ident as CI 15 | import qualified Curry.Base.SpanInfo as CSPI 16 | import qualified Curry.Syntax as CS 17 | import qualified Curry.Base.Position as CP 18 | 19 | import Control.Applicative (Alternative ((<|>))) 20 | import Control.Monad (when) 21 | import Control.Monad.State (State, execState, gets, modify) 22 | import Curry.LanguageServer.Utils.Convert (currySpanInfo2Range) 23 | import Curry.LanguageServer.Utils.General (rangeElem, joinFst, (<.$>)) 24 | import Curry.LanguageServer.Utils.Syntax 25 | ( elementAt 26 | , HasExpressions(..) 27 | , HasIdentifiers(..) 28 | , HasQualIdentifier(..) 29 | , HasQualIdentifiers(..) 30 | , HasModuleIdentifiers(..) 31 | ) 32 | import Curry.LanguageServer.Utils.Sema 33 | ( HasTypedSpanInfos(typedSpanInfos), TypedSpanInfo ) 34 | import Data.Bifunctor (Bifunctor(..)) 35 | import qualified Data.Map as M 36 | import qualified Language.LSP.Protocol.Types as J 37 | 38 | -- | A collectScope of bound identifiers. 39 | type Scope a = M.Map String (CI.Ident, Maybe a) 40 | 41 | -- | Finds identifier and (occurrence) span info at a given position. 42 | findQualIdentAtPos :: CS.Module a -> J.Position -> Maybe (CI.QualIdent, CSPI.SpanInfo) 43 | findQualIdentAtPos ast pos = qualIdent <|> exprIdent <|> basicIdent 44 | where qualIdent = withSpanInfo <$> elementAt pos (qualIdentifiers ast) 45 | exprIdent = findExprIdentAtPos ast pos 46 | basicIdent = CI.qualify <.$> withSpanInfo <$> elementAt pos (identifiers ast) 47 | 48 | --- | Finds expression identifier and (occurrence) span info at a given position. 49 | findExprIdentAtPos :: CS.Module a -> J.Position -> Maybe (CI.QualIdent, CSPI.SpanInfo) 50 | findExprIdentAtPos ast pos = joinFst $ qualIdentifier <.$> withSpanInfo <$> elementAt pos (expressions ast) 51 | 52 | -- | Finds module identifier and (occurrence) span info at a given position. 53 | findModuleIdentAtPos :: CS.Module a -> J.Position -> Maybe (CI.ModuleIdent, CSPI.SpanInfo) 54 | findModuleIdentAtPos ast pos = withSpanInfo <$> elementAt pos (moduleIdentifiers ast) 55 | 56 | -- | Finds the type at the given position. 57 | findTypeAtPos :: CS.Module a -> J.Position -> Maybe (TypedSpanInfo a) 58 | findTypeAtPos ast pos = elementAt pos $ typedSpanInfos ast 59 | 60 | -- | Finds all accessible identifiers at the given position, using the innermost shadowed one. 61 | findScopeAtPos :: CS.Module a -> J.Position -> Scope a 62 | findScopeAtPos ast pos = (.matchingEnv) $ execState (collectScope ast) $ ScopeState 63 | { currentEnv = [M.empty] 64 | , matchingEnv = M.empty 65 | , position = pos 66 | } 67 | 68 | withSpanInfo :: CSPI.HasSpanInfo a => a -> (a, CSPI.SpanInfo) 69 | withSpanInfo x = (x, CSPI.getSpanInfo x) 70 | 71 | containsPos :: CSPI.HasSpanInfo a => a -> J.Position -> Bool 72 | containsPos x pos = maybe False (rangeElem pos) $ currySpanInfo2Range x 73 | 74 | -- | Binds an identifier in the innermost scope. 75 | bindInScopes :: CI.Ident -> Maybe a -> [Scope a] -> [Scope a] 76 | bindInScopes i t (sc:scs) = M.insert (CI.idName i') (i', t) sc : scs 77 | where i' = CI.unRenameIdent i 78 | bindInScopes _ _ _ = error "Cannot bind without a scope!" 79 | 80 | -- | Shows a scope with line numbers (for debugging). 81 | showScope :: Scope a -> String 82 | showScope = show . map (second (CP.line . CSPI.getStartPosition . CI.idSpanInfo . fst)) . M.toList 83 | 84 | -- | Flattens the given scopes, preferring earlier binds. 85 | flattenScopes :: [Scope a] -> Scope a 86 | flattenScopes = M.unions 87 | 88 | -- | Stores nested scopes and a cursor position. The head of the list is always the innermost collectScope. 89 | data ScopeState a = ScopeState 90 | { currentEnv :: [Scope a] 91 | , matchingEnv :: Scope a 92 | , position :: J.Position 93 | } 94 | 95 | type ScopeM a = State (ScopeState a) 96 | 97 | beginScope :: ScopeM a () 98 | beginScope = modify $ \s -> s { currentEnv = M.empty : s.currentEnv } 99 | 100 | endScope :: ScopeM a () 101 | endScope = modify $ \s -> s { currentEnv = let e = tail s.currentEnv in if null e then error "Cannot end top-level scope!" else e } 102 | 103 | withScope :: ScopeM a () -> ScopeM a () 104 | withScope x = beginScope >> x >> endScope 105 | 106 | bind :: CI.Ident -> Maybe a -> ScopeM a () 107 | bind i t = do 108 | modify $ \s -> s { currentEnv = bindInScopes i t s.currentEnv } 109 | 110 | updateEnvs :: CSPI.HasSpanInfo e => e -> ScopeM a () 111 | updateEnvs (CSPI.getSpanInfo -> spi) = do 112 | pos <- gets (.position) 113 | when (spi `containsPos` pos) $ 114 | modify $ \s -> s { matchingEnv = M.union s.matchingEnv (flattenScopes s.currentEnv) } 115 | 116 | class CollectScope e a where 117 | collectScope :: e -> ScopeM a () 118 | 119 | instance CollectScope (CS.Module a) a where 120 | collectScope (CS.Module _ _ _ _ _ _ decls) = collectScope $ TopDecl <$> decls 121 | 122 | -- TopDecls introduce a new scope, LocalDecls don't 123 | newtype TopDecl a = TopDecl (CS.Decl a) 124 | newtype LocalDecl a = LocalDecl (CS.Decl a) 125 | 126 | instance CollectScope (TopDecl a) a where 127 | collectScope (TopDecl decl) = (>> updateEnvs decl) $ withScope $ collectScope $ LocalDecl decl 128 | 129 | instance CollectScope (LocalDecl a) a where 130 | collectScope (LocalDecl decl) = (>> updateEnvs decl) $ case decl of 131 | CS.FunctionDecl _ t i eqs -> bind i (Just t) >> collectScope eqs 132 | CS.PatternDecl _ p rhs -> collectScope p >> collectScope rhs 133 | CS.InstanceDecl _ _ _ _ _ ds -> collectScope $ TopDecl <$> ds 134 | CS.ClassDecl _ _ _ _ _ _ ds -> collectScope $ TopDecl <$> ds 135 | _ -> return () 136 | 137 | instance CollectScope (CS.Pattern a) a where 138 | collectScope pat = (>> updateEnvs pat) $ case pat of 139 | CS.VariablePattern _ t i -> bind i $ Just t 140 | CS.ConstructorPattern _ _ _ ps -> collectScope ps 141 | CS.InfixPattern _ _ p1 _ p2 -> collectScope p1 >> collectScope p2 142 | CS.ParenPattern _ p -> collectScope p 143 | CS.RecordPattern _ _ _ fs -> collectScope fs 144 | CS.TuplePattern _ ps -> collectScope ps 145 | CS.ListPattern _ _ ps -> collectScope ps 146 | CS.AsPattern _ i p -> bind i Nothing >> collectScope p 147 | CS.LazyPattern _ p -> collectScope p 148 | CS.FunctionPattern _ _ _ ps -> collectScope ps 149 | CS.InfixFuncPattern _ _ p1 _ p2 -> collectScope p1 >> collectScope p2 150 | _ -> return () 151 | 152 | 153 | instance CollectScope (CS.Equation a) a where 154 | collectScope eqn@(CS.Equation _ _ lhs rhs) = withScope $ collectScope lhs >> collectScope rhs >> updateEnvs eqn 155 | 156 | instance CollectScope (CS.Lhs a) a where 157 | collectScope lhs = (>> updateEnvs lhs) $ case lhs of 158 | -- We don't need to collect the identifier since it's already bound in the FunctionDecl. 159 | CS.FunLhs _ _ ps -> collectScope ps 160 | CS.OpLhs _ p1 _ p2 -> collectScope p1 >> collectScope p2 161 | CS.ApLhs _ l ps -> collectScope l >> collectScope ps 162 | 163 | instance CollectScope (CS.Rhs a) a where 164 | collectScope rhs = (>> updateEnvs rhs) $ case rhs of 165 | CS.SimpleRhs _ _ e ds -> collectScope e >> collectScope (LocalDecl <$> ds) 166 | CS.GuardedRhs _ _ cs ds -> collectScope cs >> collectScope (LocalDecl <$> ds) 167 | 168 | instance CollectScope (CS.CondExpr a) a where 169 | collectScope c@(CS.CondExpr _ e1 e2) = collectScope e1 >> collectScope e2 >> updateEnvs c 170 | 171 | instance CollectScope (CS.Expression a) a where 172 | collectScope expr = (>> updateEnvs expr) $ case expr of 173 | CS.Paren _ e -> collectScope e 174 | CS.Typed _ e _ -> collectScope e 175 | CS.Record _ _ _ fs -> collectScope fs 176 | CS.RecordUpdate _ e fs -> collectScope e >> collectScope fs 177 | CS.Tuple _ es -> collectScope es 178 | CS.List _ _ es -> collectScope es 179 | CS.ListCompr _ e stmts -> collectScope e >> collectScope stmts 180 | CS.EnumFrom _ e -> collectScope e 181 | CS.EnumFromThen _ e1 e2 -> collectScope e1 >> collectScope e2 182 | CS.EnumFromTo _ e1 e2 -> collectScope e1 >> collectScope e2 183 | CS.EnumFromThenTo _ e1 e2 e3 -> collectScope e1 >> collectScope e2 >> collectScope e3 184 | CS.UnaryMinus _ e -> collectScope e 185 | CS.Apply _ e1 e2 -> collectScope e1 >> collectScope e2 186 | CS.InfixApply _ e1 _ e2 -> collectScope e1 >> collectScope e2 187 | CS.LeftSection _ e _ -> collectScope e 188 | CS.RightSection _ _ e -> collectScope e 189 | CS.Lambda _ ps e -> withScope $ collectScope ps >> collectScope e 190 | -- We collect the scope twice to ensure that variables can 191 | -- be used before their declaration. 192 | CS.Let _ _ ds e -> withScope $ collectScope ds' >> collectScope ds' >> collectScope e 193 | where ds' = LocalDecl <$> ds 194 | CS.Do _ _ stmts e -> withScope $ collectScope stmts >> collectScope e 195 | CS.IfThenElse _ e1 e2 e3 -> collectScope e1 >> collectScope e2 >> collectScope e3 196 | CS.Case _ _ _ e as -> collectScope e >> collectScope as 197 | _ -> return () 198 | 199 | instance CollectScope e a => CollectScope (CS.Field e) a where 200 | collectScope f@(CS.Field _ _ e) = collectScope e >> updateEnvs f 201 | 202 | instance CollectScope (CS.Statement a) a where 203 | collectScope stmt = (>> updateEnvs stmt) $ case stmt of 204 | CS.StmtExpr _ e -> collectScope e 205 | CS.StmtDecl _ _ ds -> collectScope $ LocalDecl <$> ds 206 | CS.StmtBind _ p e -> collectScope e >> collectScope p 207 | 208 | instance CollectScope (CS.Alt a) a where 209 | collectScope alt@(CS.Alt _ p rhs) = withScope $ collectScope p >> collectScope rhs >> updateEnvs alt 210 | 211 | instance {-# OVERLAPPABLE #-} (Foldable t, CollectScope e a) => CollectScope (t e) a where 212 | collectScope = mapM_ collectScope 213 | -------------------------------------------------------------------------------- /src/Curry/LanguageServer/Utils/Sema.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, UndecidableInstances #-} 2 | -- | Utilities for extracting semantic information from the AST. 3 | module Curry.LanguageServer.Utils.Sema 4 | ( HasTypedSpanInfos (..) 5 | , TypedSpanInfo (..) 6 | , ModuleAST 7 | , untypedTopLevelDecls 8 | ) where 9 | 10 | -- Curry Compiler Libraries + Dependencies 11 | import qualified Curry.Base.Ident as CI 12 | import qualified Curry.Base.SpanInfo as CSPI 13 | import qualified Curry.Base.Position as CP 14 | import qualified Curry.Syntax as CS 15 | import qualified Curry.Frontend.Base.Types as CT 16 | 17 | import Curry.LanguageServer.Utils.Convert (ppToText) 18 | import Data.Maybe (maybeToList) 19 | import qualified Data.Set as S 20 | import qualified Data.Text as T 21 | 22 | type ModuleAST = CS.Module (Maybe CT.PredType) 23 | 24 | -- | Finds top-level function declarations in the module without an explicit type signature. 25 | untypedTopLevelDecls :: CS.Module a -> [(CSPI.SpanInfo, CI.Ident, a)] 26 | untypedTopLevelDecls (CS.Module _ _ _ _ _ _ decls) = untypedDecls 27 | where typeSigIdents = S.fromList [i | CS.TypeSig _ is _ <- decls, i <- is] 28 | untypedDecls = [(spi, i, t) | CS.FunctionDecl spi t i _ <- decls, i `S.notMember` typeSigIdents] 29 | 30 | data TypedSpanInfo a = TypedSpanInfo 31 | { exprText :: T.Text 32 | , typeAnnotation :: a 33 | , spanInfo :: CSPI.SpanInfo 34 | } 35 | deriving (Show, Eq) 36 | 37 | class HasTypedSpanInfos e a where 38 | typedSpanInfos :: e -> [TypedSpanInfo a] 39 | 40 | instance HasTypedSpanInfos (CS.Module a) a where 41 | typedSpanInfos (CS.Module _ _ _ _ _ _ decls) = typedSpanInfos decls 42 | 43 | instance HasTypedSpanInfos (CS.Decl a) a where 44 | typedSpanInfos decl = case decl of 45 | CS.FunctionDecl _ t i es -> TypedSpanInfo (ppToText i) t (CSPI.getSpanInfo i) : typedSpanInfos es 46 | CS.ExternalDecl _ vs -> typedSpanInfos vs 47 | CS.PatternDecl _ p rhs -> typedSpanInfos p ++ typedSpanInfos rhs 48 | CS.FreeDecl _ vs -> typedSpanInfos vs 49 | CS.ClassDecl _ _ _ _ _ _ ds -> typedSpanInfos ds 50 | CS.InstanceDecl _ _ _ _ _ ds -> typedSpanInfos ds 51 | _ -> [] 52 | 53 | instance HasTypedSpanInfos (CS.Equation a) a where 54 | typedSpanInfos (CS.Equation _ _ lhs rhs) = typedSpanInfos lhs ++ typedSpanInfos rhs 55 | 56 | instance HasTypedSpanInfos (CS.Var a) a where 57 | typedSpanInfos (CS.Var t i) = [TypedSpanInfo txt t $ CSPI.getSpanInfo i] 58 | where txt = ppToText i 59 | 60 | instance HasTypedSpanInfos (CS.Pattern a) a where 61 | typedSpanInfos pat = case pat of 62 | CS.LiteralPattern spi t _ -> [TypedSpanInfo txt t spi] 63 | CS.NegativePattern spi t _ -> [TypedSpanInfo txt t spi] 64 | CS.VariablePattern spi t _ -> [TypedSpanInfo txt t spi] 65 | CS.ConstructorPattern spi t _ ps -> TypedSpanInfo txt t spi : typedSpanInfos ps 66 | CS.InfixPattern spi t p1 _ p2 -> typedSpanInfos p1 ++ typedSpanInfos p2 ++ [TypedSpanInfo txt t spi] 67 | CS.ParenPattern _ p -> typedSpanInfos p 68 | CS.RecordPattern spi t _ fs -> TypedSpanInfo txt t spi : typedSpanInfos fs 69 | CS.TuplePattern _ ps -> typedSpanInfos ps 70 | CS.ListPattern spi t ps -> TypedSpanInfo txt t spi : typedSpanInfos ps 71 | CS.AsPattern _ _ p -> typedSpanInfos p 72 | CS.LazyPattern _ p -> typedSpanInfos p 73 | CS.FunctionPattern spi t _ ps -> TypedSpanInfo txt t spi : typedSpanInfos ps 74 | CS.InfixFuncPattern spi t p1 _ p2 -> typedSpanInfos p1 ++ typedSpanInfos p2 ++ [TypedSpanInfo txt t spi] 75 | where txt = ppToText pat 76 | 77 | instance HasTypedSpanInfos e a => HasTypedSpanInfos (CS.Field e) a where 78 | typedSpanInfos (CS.Field _ _ e) = typedSpanInfos e 79 | 80 | instance HasTypedSpanInfos (CS.Lhs a) a where 81 | typedSpanInfos lhs = case lhs of 82 | CS.FunLhs _ _ ps -> typedSpanInfos ps 83 | CS.OpLhs _ p1 _ p2 -> typedSpanInfos p1 ++ typedSpanInfos p2 84 | CS.ApLhs _ l ps -> typedSpanInfos l ++ typedSpanInfos ps 85 | 86 | instance HasTypedSpanInfos (CS.Rhs a) a where 87 | typedSpanInfos rhs = case rhs of 88 | CS.SimpleRhs _ _ e ds -> typedSpanInfos e ++ typedSpanInfos ds 89 | CS.GuardedRhs _ _ es ds -> typedSpanInfos es ++ typedSpanInfos ds 90 | 91 | instance HasTypedSpanInfos (CS.CondExpr a) a where 92 | typedSpanInfos (CS.CondExpr _ e1 e2) = typedSpanInfos e1 ++ typedSpanInfos e2 93 | 94 | instance HasTypedSpanInfos (CS.Expression a) a where 95 | typedSpanInfos expr = case expr of 96 | CS.Literal spi t _ -> [TypedSpanInfo txt t spi] 97 | CS.Variable spi t _ -> [TypedSpanInfo txt t spi] 98 | CS.Constructor spi t _ -> [TypedSpanInfo txt t spi] 99 | CS.Paren _ e -> typedSpanInfos e 100 | CS.Typed _ e _ -> typedSpanInfos e 101 | CS.Record spi t _ fs -> TypedSpanInfo txt t spi : typedSpanInfos fs 102 | CS.RecordUpdate _ e fs -> typedSpanInfos e ++ typedSpanInfos fs 103 | CS.Tuple _ es -> typedSpanInfos es 104 | CS.List spi t es -> TypedSpanInfo txt t spi : typedSpanInfos es 105 | CS.ListCompr _ e stmts -> typedSpanInfos e ++ typedSpanInfos stmts 106 | CS.EnumFrom _ e -> typedSpanInfos e 107 | CS.EnumFromThen _ e1 e2 -> typedSpanInfos e1 ++ typedSpanInfos e2 108 | CS.EnumFromTo _ e1 e2 -> typedSpanInfos e1 ++ typedSpanInfos e2 109 | CS.EnumFromThenTo _ e1 e2 e3 -> typedSpanInfos e1 ++ typedSpanInfos e2 ++ typedSpanInfos e3 110 | CS.UnaryMinus _ e -> typedSpanInfos e 111 | CS.Apply _ e1 e2 -> typedSpanInfos e1 ++ typedSpanInfos e2 112 | CS.InfixApply _ e1 op e2 -> typedSpanInfos e1 ++ typedSpanInfos op ++ typedSpanInfos e2 113 | CS.LeftSection _ e1 op -> typedSpanInfos e1 ++ typedSpanInfos op 114 | CS.RightSection _ op e2 -> typedSpanInfos op ++ typedSpanInfos e2 115 | CS.Lambda _ ps e -> typedSpanInfos ps ++ typedSpanInfos e 116 | CS.Let _ _ ds e -> typedSpanInfos ds ++ typedSpanInfos e 117 | CS.Do _ _ stmts e -> typedSpanInfos stmts ++ typedSpanInfos e 118 | CS.IfThenElse _ e1 e2 e3 -> typedSpanInfos e1 ++ typedSpanInfos e2 ++ typedSpanInfos e3 119 | CS.Case _ _ _ e as -> typedSpanInfos e ++ typedSpanInfos as 120 | where txt = ppToText expr 121 | 122 | instance HasTypedSpanInfos (CS.Alt a) a where 123 | typedSpanInfos (CS.Alt _ p rhs) = typedSpanInfos p ++ typedSpanInfos rhs 124 | 125 | instance HasTypedSpanInfos (CS.InfixOp a) a where 126 | typedSpanInfos op = case op of 127 | CS.InfixOp t q -> [TypedSpanInfo txt t $ CSPI.getSpanInfo q] 128 | CS.InfixConstr t q -> [TypedSpanInfo txt t $ CSPI.getSpanInfo q] 129 | where txt = ppToText op 130 | 131 | instance HasTypedSpanInfos (CS.Statement a) a where 132 | typedSpanInfos stmt = case stmt of 133 | CS.StmtExpr _ e -> typedSpanInfos e 134 | CS.StmtDecl _ _ ds -> typedSpanInfos ds 135 | CS.StmtBind _ p e -> typedSpanInfos p ++ typedSpanInfos e 136 | 137 | instance HasTypedSpanInfos e a => HasTypedSpanInfos [e] a where 138 | typedSpanInfos = (typedSpanInfos =<<) 139 | 140 | instance HasTypedSpanInfos e a => HasTypedSpanInfos (Maybe e) a where 141 | typedSpanInfos = typedSpanInfos . maybeToList 142 | 143 | instance CP.HasPosition (TypedSpanInfo a) where 144 | getPosition (TypedSpanInfo _ _ spi) = CP.getPosition spi 145 | 146 | instance CSPI.HasSpanInfo (TypedSpanInfo a) where 147 | getSpanInfo (TypedSpanInfo _ _ spi) = spi 148 | setSpanInfo spi (TypedSpanInfo txt t _) = TypedSpanInfo txt t spi 149 | -------------------------------------------------------------------------------- /src/Curry/LanguageServer/Utils/Uri.hs: -------------------------------------------------------------------------------- 1 | -- | Accurate (canonicalized) mappings between URIs and file paths. 2 | module Curry.LanguageServer.Utils.Uri 3 | ( filePathToUri 4 | , uriToFilePath 5 | , filePathToNormalizedUri 6 | , normalizedUriToFilePath 7 | , normalizeUriWithPath 8 | ) where 9 | 10 | import Control.Monad.IO.Class (MonadIO (..)) 11 | import qualified Language.LSP.Protocol.Types as J 12 | import System.Directory (canonicalizePath) 13 | 14 | filePathToUri :: MonadIO m => FilePath -> m J.Uri 15 | filePathToUri = liftIO . (J.filePathToUri <$>) . canonicalizePath 16 | 17 | uriToFilePath :: J.Uri -> Maybe FilePath 18 | uriToFilePath = J.uriToFilePath 19 | 20 | filePathToNormalizedUri :: MonadIO m => FilePath -> m J.NormalizedUri 21 | filePathToNormalizedUri = liftIO . (J.toNormalizedUri <$>) . filePathToUri 22 | 23 | normalizedUriToFilePath :: J.NormalizedUri -> Maybe FilePath 24 | normalizedUriToFilePath = uriToFilePath . J.fromNormalizedUri 25 | 26 | -- | Normalizes a URI by converting to a file path and back (thus ensuring 27 | -- consistent formatting e.g. of drive letters on Windows). 28 | normalizeUriWithPath :: MonadIO m => J.Uri -> m J.NormalizedUri 29 | normalizeUriWithPath uri = liftIO (J.toNormalizedUri <$> maybe (return uri) filePathToUri (uriToFilePath uri)) 30 | -------------------------------------------------------------------------------- /src/Curry/LanguageServer/Utils/VFS.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings, MultiWayIf #-} 2 | module Curry.LanguageServer.Utils.VFS 3 | ( PosPrefixInfo (..) 4 | , getCompletionPrefix 5 | ) where 6 | 7 | import Data.Maybe (listToMaybe, fromMaybe) 8 | import qualified Data.Text as T 9 | import qualified Data.Text.Utf16.Rope.Mixed as Rope 10 | import qualified Language.LSP.Protocol.Types as J 11 | import qualified Language.LSP.VFS as VFS 12 | import Data.Char (isAlphaNum) 13 | 14 | -- Source: https://github.com/haskell/haskell-language-server/blob/a4bcaa31/ghcide/src/Development/IDE/Plugin/Completions/Types.hs#L134-L152 15 | -- License: Apache 2.0 16 | 17 | -- | Describes the line at the current cursor position 18 | data PosPrefixInfo = PosPrefixInfo 19 | { fullLine :: !T.Text 20 | -- ^ The full contents of the line the cursor is at 21 | 22 | , prefixScope :: !T.Text 23 | -- ^ If any, the module name that was typed right before the cursor position. 24 | -- For example, if the user has typed "Data.Maybe.from", then this property 25 | -- will be "Data.Maybe" 26 | -- If OverloadedRecordDot is enabled, "Shape.rect.width" will be 27 | -- "Shape.rect" 28 | 29 | , prefixText :: !T.Text 30 | -- ^ The word right before the cursor position, after removing the module part. 31 | -- For example if the user has typed "Data.Maybe.from", 32 | -- then this property will be "from" 33 | , cursorPos :: !J.Position 34 | -- ^ The cursor position 35 | } deriving (Show,Eq) 36 | 37 | -- Source: https://github.com/haskell/haskell-language-server/blob/a4bcaa31/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs#L889-L916 38 | -- License: Apache 2.0 39 | 40 | getCompletionPrefix :: J.Position -> VFS.VirtualFile -> PosPrefixInfo 41 | getCompletionPrefix pos (VFS.VirtualFile _ _ ropetext) = getCompletionPrefixFromRope pos ropetext 42 | 43 | getCompletionPrefixFromRope :: J.Position -> Rope.Rope -> PosPrefixInfo 44 | getCompletionPrefixFromRope pos@(J.Position l c) ropetext = 45 | fromMaybe (PosPrefixInfo "" "" "" pos) $ do -- Maybe monad 46 | let headMaybe = listToMaybe 47 | lastMaybe = headMaybe . reverse 48 | 49 | -- grab the entire line the cursor is at 50 | curLine <- headMaybe $ Rope.lines 51 | $ fst $ Rope.splitAtLine 1 $ snd $ Rope.splitAtLine (fromIntegral l) ropetext 52 | let beforePos = T.take (fromIntegral c) curLine 53 | -- the word getting typed, after previous space and before cursor 54 | curWord <- 55 | if | T.null beforePos -> Just "" 56 | | T.last beforePos == ' ' -> Just "" -- don't count abc as the curword in 'abc ' 57 | | otherwise -> lastMaybe (T.words beforePos) 58 | 59 | let parts = T.split (=='.') 60 | $ T.takeWhileEnd (\x -> isAlphaNum x || x `elem` ("._'"::String)) curWord 61 | case reverse parts of 62 | [] -> Nothing 63 | (x:xs) -> do 64 | let modParts = reverse $ filter (not .T.null) xs 65 | modName = T.intercalate "." modParts 66 | return $ PosPrefixInfo { fullLine = curLine, prefixScope = modName, prefixText = x, cursorPos = pos } 67 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | # This file was automatically generated by 'stack init' 2 | # 3 | # Some commonly used options have been documented as comments in this file. 4 | # For advanced use and comprehensive documentation of the format, please see: 5 | # https://docs.haskellstack.org/en/stable/yaml_configuration/ 6 | 7 | # Resolver to choose a 'specific' stackage snapshot or a compiler version. 8 | # A snapshot resolver dictates the compiler version and the set of packages 9 | # to be used for project dependencies. 10 | resolver: lts-22.41 11 | 12 | # User packages to be built. 13 | packages: 14 | - . 15 | # Dependency packages to be pulled from upstream that are not in the resolver. 16 | # These entries can reference officially published versions as well as 17 | # forks / in-progress versions pinned to a git hash. For example: 18 | extra-deps: 19 | - aeson-2.2.3.0 20 | - binary-0.8.9.2 21 | - bytestring-0.12.1.0 22 | - character-ps-0.1 23 | - containers-0.7 24 | - directory-1.3.8.5 25 | - extra-1.8 26 | - filepath-1.4.300.2 27 | - lsp-2.7.0.0 28 | - lsp-types-2.3.0.0 29 | - parsec-3.1.17.0 30 | - process-1.6.20.0 31 | - set-extra-1.4.2 32 | - text-2.1.1 33 | - time-1.9.3 34 | - unix-2.8.5.1 35 | - Win32-2.14.1.0 36 | - git: https://git.ps.informatik.uni-kiel.de/curry/curry-frontend.git 37 | commit: 6919240bf82cc94a2d47bd405e70565c272f98f8 38 | 39 | allow-newer: true 40 | 41 | # Override default flag values for local packages and extra-deps 42 | # flags: {} 43 | 44 | # Extra package databases containing global packages 45 | # extra-package-dbs: [] 46 | 47 | # Control whether we use the GHC we find on the path 48 | # system-ghc: true 49 | # 50 | # Require a specific version of stack, using version ranges 51 | # require-stack-version: -any # Default 52 | # require-stack-version: ">=2.1" 53 | # 54 | # Override the architecture used by stack, especially useful on Windows 55 | # arch: i386 56 | # arch: x86_64 57 | # 58 | # Extra directories used by stack for building 59 | # extra-include-dirs: [/path/to/dir] 60 | # extra-lib-dirs: [/path/to/dir] 61 | # 62 | # Allow a newer minor version of GHC than the snapshot specifies 63 | # compiler-check: newer-minor 64 | -------------------------------------------------------------------------------- /stack.yaml.lock: -------------------------------------------------------------------------------- 1 | # This file was autogenerated by Stack. 2 | # You should not edit this file by hand. 3 | # For more information, please see the documentation at: 4 | # https://docs.haskellstack.org/en/stable/topics/lock_files 5 | 6 | packages: 7 | - completed: 8 | hackage: aeson-2.2.3.0@sha256:011fa2d67d7a821aa5ec5c825adc919bb067d42dde8fac7c6e5db23239a58866,6589 9 | pantry-tree: 10 | sha256: e928995a568c7437575160844341219a5b057fc8e27f51162da8595692e2500c 11 | size: 83371 12 | original: 13 | hackage: aeson-2.2.3.0 14 | - completed: 15 | hackage: binary-0.8.9.2@sha256:03381e511429c44d13990c6d76281c4fc2468371cede4fe684b0c98d9b7d5f5a,6611 16 | pantry-tree: 17 | sha256: 7fac13c81b45416bd082c34e31cc3ac19226dd15354f379156922ad4cfbe6285 18 | size: 1976 19 | original: 20 | hackage: binary-0.8.9.2 21 | - completed: 22 | hackage: bytestring-0.12.1.0@sha256:98e79e1c97117143e4012983509ec95f7e5e4f6adff6914d07812a39f83404b9,9473 23 | pantry-tree: 24 | sha256: 89aac3892a1f67b0b18fec87ac3eaf417b8698e5f231a25b571ac91d085943d3 25 | size: 4650 26 | original: 27 | hackage: bytestring-0.12.1.0 28 | - completed: 29 | hackage: character-ps-0.1@sha256:b38ed1c07ae49e7461e44ca1d00c9ca24d1dcb008424ccd919916f92fd48d9fe,1315 30 | pantry-tree: 31 | sha256: 22d98d7c8b4c2bb9cb7fe429adf52bfed0c18269eac146b1e591c5941e26161a 32 | size: 382 33 | original: 34 | hackage: character-ps-0.1 35 | - completed: 36 | hackage: containers-0.7@sha256:e9b5fdcc609159410d408c47e0be13663bb0b4a42a5183b52aa0ac9c99e1dfec,2668 37 | pantry-tree: 38 | sha256: 265b0a6110df990b5f9f04d21856333ed5ed66f37a4b0a0215901d831f69629b 39 | size: 2954 40 | original: 41 | hackage: containers-0.7 42 | - completed: 43 | hackage: directory-1.3.8.5@sha256:fbeec9ec346e5272167f63dcb86af513b457a7b9fc36dc818e4c7b81608d612b,3166 44 | pantry-tree: 45 | sha256: d11130a0ca9e7c8720ed1ceef4e2f0d9be4b446e67e7d15d634763a5c952877e 46 | size: 3519 47 | original: 48 | hackage: directory-1.3.8.5 49 | - completed: 50 | hackage: extra-1.8@sha256:57d9200fbea2e88e05e0be35925511764827b1c86d3214106b0b610f331fc40c,2725 51 | pantry-tree: 52 | sha256: 3aafb822ea6975fa23384ef35d82bd67442b302795bf6a58c98b366e75302a1f 53 | size: 1961 54 | original: 55 | hackage: extra-1.8 56 | - completed: 57 | hackage: filepath-1.4.300.2@sha256:345cbb1afe414a09e47737e4d14cbd51891a734e67c0ef3d77a1439518bb81e8,5900 58 | pantry-tree: 59 | sha256: 2420f7addc917bf41970a8980f52abe431b1a0fb711b00795effbb289c8ea76c 60 | size: 3998 61 | original: 62 | hackage: filepath-1.4.300.2 63 | - completed: 64 | hackage: lsp-2.7.0.0@sha256:2a64b40a69fd9638056ca552d5660203019473061cff1d09dccc0c94e40a275c,3834 65 | pantry-tree: 66 | sha256: 630a5e18d7783c35a296268959c8d9348ee6dc94540047ea58146b310d8de941 67 | size: 1120 68 | original: 69 | hackage: lsp-2.7.0.0 70 | - completed: 71 | hackage: lsp-types-2.3.0.0@sha256:ca17a686bda5dc7ff04105ca7081dce5a90bcd050c8800a13efd68b7f0901f1c,34215 72 | pantry-tree: 73 | sha256: 0bf22e394dc804c8cee74d19a7f38021cfd48a15082b39a14753c037f2a64288 74 | size: 51996 75 | original: 76 | hackage: lsp-types-2.3.0.0 77 | - completed: 78 | hackage: parsec-3.1.17.0@sha256:8407cbd428d7f640a0fff8891bd2f7aca13cebe70a5e654856f8abec9a648b56,5149 79 | pantry-tree: 80 | sha256: 0922d72bd7115bbb590757bd92a827021dfe745ed6c0cd22856f767bee83d91f 81 | size: 2810 82 | original: 83 | hackage: parsec-3.1.17.0 84 | - completed: 85 | hackage: process-1.6.20.0@sha256:2a9393de33f18415fb8f4826957a87a94ffe8840ca8472a9b69dca6de45aca03,2790 86 | pantry-tree: 87 | sha256: 14d1e9a5ec731766e43c7eb9c2dc59a7da48d98d43374d9d83e725d8891c6173 88 | size: 1789 89 | original: 90 | hackage: process-1.6.20.0 91 | - completed: 92 | hackage: set-extra-1.4.2@sha256:a1a3899d7ae01cd72dfd4691ae77cf26e8867731dff70e61307f25ddc7fd875d,564 93 | pantry-tree: 94 | sha256: 439f8bd6732a4d250a9e565c5bbcf393f3374e8e346e634494efd62b388fe810 95 | size: 268 96 | original: 97 | hackage: set-extra-1.4.2 98 | - completed: 99 | hackage: text-2.1.1@sha256:78c3fb91055d0607a80453327f087b9dc82168d41d0dca3ff410d21033b5e87d,10653 100 | pantry-tree: 101 | sha256: 8251d517ceafa2680250ddb939f4a2b89bf231314cf6a218134af900e154d7cd 102 | size: 8413 103 | original: 104 | hackage: text-2.1.1 105 | - completed: 106 | hackage: time-1.9.3@sha256:8f1b5448722a12a952248b356c9eb366e351226543d9086a2da71270522d5f45,5679 107 | pantry-tree: 108 | sha256: a1043c1719491764f0fa37a1fd70d9451080548a41632fee88d8e1b8db4942d6 109 | size: 6558 110 | original: 111 | hackage: time-1.9.3 112 | - completed: 113 | hackage: unix-2.8.5.1@sha256:3f702a252a313a7bcb56e3908a14e7f9f1b40e41b7bdc8ae8a9605a1a8686f06,9808 114 | pantry-tree: 115 | sha256: b961320db69795a16c4ef4eebb0a3e7ddbbbe506fa1e22dde95ee8d8501bfbe5 116 | size: 5821 117 | original: 118 | hackage: unix-2.8.5.1 119 | - completed: 120 | hackage: Win32-2.14.1.0@sha256:983e8882ad5663fc3b738044dbebfe42fd4e37f7f3d7c7e0b085702c9ece6d9f,5753 121 | pantry-tree: 122 | sha256: 3dee6648c08272ef629d7cd045ba05ee28212469ebae72d3b2175c785c677051 123 | size: 8300 124 | original: 125 | hackage: Win32-2.14.1.0 126 | - completed: 127 | commit: 6919240bf82cc94a2d47bd405e70565c272f98f8 128 | git: https://git.ps.informatik.uni-kiel.de/curry/curry-frontend.git 129 | name: curry-frontend 130 | pantry-tree: 131 | sha256: f2117dffee864bde5f9b5fb0a414787b25acc4fb7a7e0dda1d626339e57c2ceb 132 | size: 21908 133 | version: 3.0.0 134 | original: 135 | commit: 6919240bf82cc94a2d47bd405e70565c272f98f8 136 | git: https://git.ps.informatik.uni-kiel.de/curry/curry-frontend.git 137 | snapshots: 138 | - completed: 139 | sha256: 1e32b51d9082fdf6f3bd92accc9dfffd4ddaf406404427fb10bf76d2bc03cbbb 140 | size: 720263 141 | url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/22/41.yaml 142 | original: lts-22.41 143 | -------------------------------------------------------------------------------- /test/Spec.hs: -------------------------------------------------------------------------------- 1 | main :: IO () 2 | main = putStrLn "TODO" 3 | -------------------------------------------------------------------------------- /test/resources/Demo.curry: -------------------------------------------------------------------------------- 1 | module Demo where 2 | 3 | test :: Int 4 | test = 4 5 | -------------------------------------------------------------------------------- /test/resources/Test.curry: -------------------------------------------------------------------------------- 1 | module Test where 2 | 3 | import Demo 4 | 5 | f x = case x of 6 | _ -> 3 7 | _ -> 5 8 | --------------------------------------------------------------------------------