├── .github └── workflows │ ├── mac-bundle-dylib.sh │ ├── release.yaml │ └── test.yaml ├── .gitignore ├── CHANGELOG.md ├── LICENSE ├── README.md ├── Setup.hs ├── agda-language-server.cabal ├── app └── Main.hs ├── hie.yaml ├── package.yaml ├── src ├── Agda.hs ├── Agda │ ├── Convert.hs │ ├── IR.hs │ ├── Parser.hs │ └── Position.hs ├── Control │ └── Concurrent │ │ └── SizedChan.hs ├── Monad.hs ├── Options.hs ├── Render.hs ├── Render │ ├── Class.hs │ ├── Common.hs │ ├── Concrete.hs │ ├── Interaction.hs │ ├── Internal.hs │ ├── Literal.hs │ ├── Name.hs │ ├── Position.hs │ ├── RichText.hs │ ├── TypeChecking.hs │ └── Utils.hs ├── Server.hs ├── Server │ ├── CommandController.hs │ ├── Handler.hs │ └── ResponseController.hs └── Switchboard.hs ├── stack-9.2-Agda-2.6.3.yaml ├── stack-9.2-Agda-2.6.3.yaml.lock ├── stack-9.2-Agda-2.6.4.3.yaml ├── stack-9.2-Agda-2.6.4.3.yaml.lock ├── stack-9.2-Agda-2.7.0.1.yaml ├── stack-9.2-Agda-2.7.0.1.yaml.lock ├── stack.yaml ├── stack.yaml.lock └── test ├── Test.hs ├── Test ├── LSP.hs └── SrcLoc.hs └── data └── A.agda /.github/workflows/mac-bundle-dylib.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | # Bundle icu4c DLLs 3 | 4 | # see if icu4c has been installed 5 | if [ "$(brew list | grep icu4c)" = "" ] 6 | then 7 | echo "installing icu4c" 8 | brew install icu4c 9 | fi 10 | 11 | # get the directory of the DDLs we want (icuuc, icui18n, icudata) 12 | dylib_dir=$(dirname "$(brew list icu4c | grep icuuc.dylib)") 13 | 14 | # find the path of "als" 15 | executable=$(find "$(stack path --local-install-root)"/bin -name "als") 16 | 17 | # remove the old dylib, and make a new one 18 | rm -rf dylib 19 | mkdir dylib 20 | 21 | ################################################################################ 22 | # icuuc 23 | ################################################################################ 24 | 25 | icuuc_id=$(otool -L "$executable" | grep icuuc | awk '{print $1}') 26 | icuuc_id_basename=$(basename "$icuuc_id") 27 | 28 | icuuc_path=$dylib_dir/$icuuc_id_basename 29 | icuuc_path_new=dylib/$icuuc_id_basename 30 | icuuc_id_new=@loader_path/dylib/$icuuc_id_basename 31 | 32 | # copy icuuc to the new directory 33 | cp "$icuuc_path" "$icuuc_path_new" 34 | 35 | # change icuuc's ID referenced by ALS 36 | install_name_tool -change "$icuuc_id" "$icuuc_id_new" "$executable" 37 | 38 | echo "icuuc referenced by ALS" 39 | echo " old ID : $icuuc_id" 40 | echo " new ID : $icuuc_id_new" 41 | echo " old path: $icuuc_path" 42 | echo " new path: $icuuc_path_new" 43 | 44 | ################################################################################ 45 | # icui18n 46 | ################################################################################ 47 | 48 | icui18n_id=$(otool -L "$executable" | grep icui18n | awk '{print $1}') 49 | icui18n_id_basename=$(basename "$icui18n_id") 50 | 51 | icui18n_path=$dylib_dir/$icui18n_id_basename 52 | icui18n_path_new=dylib/$icui18n_id_basename 53 | icui18n_id_new=@loader_path/dylib/$icui18n_id_basename 54 | 55 | # copy icui18n to the new directory 56 | cp "$icui18n_path" "$icui18n_path_new" 57 | 58 | # change icui18n's ID referenced by ALS 59 | install_name_tool -change "$icui18n_id" "$icui18n_id_new" "$executable" 60 | 61 | echo "icui18n referenced by ALS" 62 | echo " old ID : $icui18n_id" 63 | echo " new ID : $icui18n_id_new" 64 | echo " old path: $icui18n_path" 65 | echo " new path: $icui18n_path_new" 66 | 67 | ################################################################################ 68 | # icudata 69 | ################################################################################ 70 | 71 | # otool -L "$icui18n_id" | grep icudata | awk '{print $1}' 72 | icudata_id=$(otool -L "$icuuc_path" | grep icudata | awk '{print $1}') 73 | icudata_id_basename=$(basename "$icudata_id") 74 | 75 | icudata_path=$dylib_dir/$icudata_id_basename 76 | icudata_path_new=dylib/$icudata_id_basename 77 | 78 | # copy icudata to the new directory 79 | cp "$icudata_path" "$icudata_path_new" 80 | 81 | # no need of changing the ID because supposely it's already of "@loader_path" 82 | 83 | echo "icudata referenced by icuuc" 84 | echo " old ID : $icudata_id" 85 | echo " old path : $icudata_path" 86 | echo " new path : $icudata_path_new" 87 | -------------------------------------------------------------------------------- /.github/workflows/release.yaml: -------------------------------------------------------------------------------- 1 | name: Release 2 | 3 | on: 4 | push: 5 | tags: 6 | - 'v*' # Push events to matching v*, i.e. v1.0, v20.15.10 7 | 8 | jobs: 9 | release: 10 | name: Create Github Release 11 | if: startsWith(github.ref, 'refs/tags/v') 12 | runs-on: ubuntu-latest 13 | steps: 14 | 15 | - name: 📥 Checkout repository 16 | uses: actions/checkout@v4 17 | 18 | - name: 🏭 Create Release 19 | run: | 20 | gh release create ${{ github.ref_name }} --generate-notes 21 | env: 22 | GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }} 23 | 24 | # - name: ⏫ Upload to Hackage 25 | # id: upload_hackage 26 | # env: 27 | # HACKAGE_API_KEY: ${{ secrets.HACKAGE_API_KEY }} 28 | # uses: freckle/stack-upload-action@main 29 | -------------------------------------------------------------------------------- /.github/workflows/test.yaml: -------------------------------------------------------------------------------- 1 | # modified from https://github.com/simonmichael/hledger/blob/master/.github/workflows/linux.yml 2 | 3 | name: CI 4 | 5 | defaults: 6 | run: 7 | shell: bash 8 | 9 | on: 10 | push: 11 | branches: [master, ci-*, ci] 12 | tags: 13 | - 'v*' # Push events to matching v*, i.e. v1.0, v20.15.10 14 | pull_request: 15 | branches: [master] 16 | 17 | jobs: 18 | build-and-test: 19 | runs-on: ${{ matrix.os }} 20 | strategy: 21 | matrix: 22 | os: [windows-latest, ubuntu-latest, macos-latest, macos-13] 23 | agda: ['Agda-2.7.0.1', 'Agda-2.6.4.3', 'Agda-2.6.3'] 24 | fail-fast: false 25 | steps: 26 | 27 | - name: 📥 Checkout repository 28 | uses: actions/checkout@v4 29 | 30 | - name: 📤 Install yq (Windows) 31 | if: runner.os == 'Windows' 32 | uses: frenck/action-setup-yq@v1 33 | 34 | - name: 🎛️ Determine which version of Agda to target 35 | run: | 36 | STACK_YAML=$(echo stack-9.2-${{ matrix.agda }}.yaml) 37 | STACK_YAML_ARG="--stack-yaml $(echo stack-9.2-${{ matrix.agda }}.yaml)" 38 | 39 | if [[ ${{ matrix.os }} == "ubuntu-latest" ]]; then 40 | ARTEFACT="als-${{ matrix.agda }}-ubuntu" 41 | fi 42 | if [[ ${{ matrix.os }} == "macos-latest" ]]; then 43 | ARTEFACT="als-${{ matrix.agda }}-macos-arm64" 44 | fi 45 | if [[ ${{ matrix.os }} == "macos-13" ]]; then 46 | ARTEFACT="als-${{ matrix.agda }}-macos-x64" 47 | fi 48 | if [[ ${{ matrix.os }} == "windows-latest" ]]; then 49 | ARTEFACT="als-${{ matrix.agda }}-windows" 50 | fi 51 | 52 | echo STACK_YAML_ARG="${STACK_YAML_ARG}" >> "${GITHUB_ENV}" 53 | echo STACK_YAML="${STACK_YAML}" >> "${GITHUB_ENV}" 54 | echo ARTEFACT="${ARTEFACT}" >> "${GITHUB_ENV}" 55 | 56 | - name: 🎛️ Determine Stack resolver & GHC version 57 | run: | 58 | STACK_RESOLVER=$(yq .resolver $STACK_YAML) 59 | GHC_VERSION=$(echo $(yq .compiler $STACK_YAML) | cut -c 5-) 60 | echo STACK_RESOLVER="${STACK_RESOLVER}" >> "${GITHUB_ENV}" 61 | echo GHC_VERSION="${GHC_VERSION}" >> "${GITHUB_ENV}" 62 | 63 | - name: 🏗 Setup Haskell 64 | if : runner.os == 'macOS' 65 | uses: haskell-actions/setup@v2 66 | id: setup-haskell 67 | with: 68 | ghc-version: ${{ env.GHC_VERSION }} 69 | enable-stack: true 70 | stack-version: 'latest' 71 | 72 | - name: 🎛️ Determine Stack root 73 | run: | 74 | STACK_ROOT="$(stack path $STACK_YAML_ARG --stack-root)" 75 | echo STACK_ROOT="${STACK_ROOT}" >> "${GITHUB_ENV}" 76 | 77 | - name: 🔍 Review all variables 78 | run: | 79 | echo "STACK_YAML = ${STACK_YAML}" 80 | echo "STACK_YAML_ARG = ${STACK_YAML_ARG}" 81 | echo "STACK_RESOLVER = ${STACK_RESOLVER}" 82 | echo "ARTEFACT = ${ARTEFACT}" 83 | echo "GHC_VERSION = ${GHC_VERSION}" 84 | echo "STACK_ROOT = ${STACK_ROOT}" 85 | 86 | # things to be restored: 87 | # Include STACK_RESOLVER in cache key, otherwise caches accumulate build products for different resolvers. 88 | 89 | - name: 💾 Restore cached stack global package db 90 | id: stack-global 91 | uses: actions/cache/restore@v4 92 | with: 93 | path: ${{ env.STACK_ROOT }} 94 | key: ${{ matrix.os }}-stack-resolver-${{ env.STACK_RESOLVER }}-global-${{ hashFiles('**.yaml') }}-${{ matrix.agda }} 95 | restore-keys: | 96 | ${{ matrix.os }}-stack-resolver-${{ env.STACK_RESOLVER }}-global 97 | 98 | - name: 💾 Restore cached .stack-work 99 | id: stack-work 100 | uses: actions/cache/restore@v4 101 | with: 102 | path: .stack-work 103 | key: ${{ matrix.os }}-stack-resolver-${{ env.STACK_RESOLVER }}-work-${{ hashFiles('**.yaml') }}-${{ matrix.agda }} 104 | restore-keys: | 105 | ${{ matrix.os }}-stack-resolver-${{ env.STACK_RESOLVER }}-work 106 | 107 | # actions: 108 | - name: ⚙️ Set PKG_CONFIG_PATH for the ICU library (on macOS) 109 | if: runner.os == 'macOS' 110 | run: | 111 | echo PKG_CONFIG_PATH="$(brew --prefix)/opt/icu4c/lib/pkgconfig" >> "${GITHUB_ENV}" 112 | 113 | - name: 📥 Install the icu library (on Windows) 114 | if: runner.os == 'Windows' 115 | run: | 116 | stack exec $STACK_YAML_ARG -- pacman -S --noconfirm mingw-w64-x86_64-icu mingw-w64-x86_64-pkgconf 117 | 118 | - name: 📸 Build Snapshot 119 | run: stack build $STACK_YAML_ARG --no-terminal --only-snapshot -j1 120 | 121 | - name: 🏗️ Build Dependencies 122 | run: stack build $STACK_YAML_ARG --no-terminal --only-dependencies 123 | 124 | - name: 🏗️ Build ALS 125 | run: stack build $STACK_YAML_ARG 126 | 127 | - name: 🏗️ Build Testings 128 | run: stack build $STACK_YAML_ARG --test --no-terminal --only-dependencies 129 | 130 | # things to be cached 131 | 132 | - name: 💾 Cache stack global package db 133 | if: always() && steps.stack-global.outputs.cache-hit != 'true' 134 | uses: actions/cache/save@v4 135 | with: 136 | path: ${{ env.STACK_ROOT }} 137 | key: ${{ steps.stack-global.outputs.cache-primary-key }} 138 | 139 | - name: 💾 Cache .stack-work 140 | if: always() && steps.stack-work.outputs.cache-hit != 'true' 141 | uses: actions/cache/save@v4 142 | with: 143 | path: .stack-work 144 | key: ${{ steps.stack-work.outputs.cache-primary-key }} 145 | 146 | 147 | - name: 📦 Bundle executable, DLLs and data files (on macOS) 148 | if: runner.os == 'macOS' 149 | run: | # Bundle icu4c DLLs 150 | 151 | # see if icu4c has been installed 152 | if [ "$(brew list | grep icu4c)" = "" ] 153 | then 154 | echo "installing icu4c" 155 | brew install icu4c 156 | fi 157 | 158 | # get the directory of the DDLs we want (icuuc, icui18n, icudata) 159 | dylib_dir=$(dirname "$(brew list icu4c | grep icuuc.dylib)") 160 | echo "dylib_dir: $dylib_dir" 161 | 162 | # find the path of "als" 163 | executable=$(find "$(stack path $STACK_YAML_ARG --local-install-root)"/bin -name "als") 164 | echo "executable: $executable" 165 | 166 | # remove the old dylib, and make a new one 167 | rm -rf dylib 168 | mkdir dylib 169 | 170 | ################################################################################ 171 | # icuuc 172 | ################################################################################ 173 | 174 | icuuc_id=$(otool -L "$executable" | grep icuuc | awk '{print $1}') 175 | icuuc_id_basename=$(basename "$icuuc_id") 176 | 177 | icuuc_path=$dylib_dir/$icuuc_id_basename 178 | icuuc_path_new=dylib/$icuuc_id_basename 179 | icuuc_id_new=@loader_path/dylib/$icuuc_id_basename 180 | 181 | # copy icuuc to the new directory 182 | cp "$icuuc_path" "$icuuc_path_new" 183 | 184 | # change icuuc's ID referenced by ALS 185 | install_name_tool -change "$icuuc_id" "$icuuc_id_new" "$executable" 186 | 187 | echo "icuuc referenced by ALS" 188 | echo " old ID : $icuuc_id" 189 | echo " new ID : $icuuc_id_new" 190 | echo " old path: $icuuc_path" 191 | echo " new path: $icuuc_path_new" 192 | 193 | ################################################################################ 194 | # icui18n 195 | ################################################################################ 196 | 197 | icui18n_id=$(otool -L "$executable" | grep icui18n | awk '{print $1}') 198 | icui18n_id_basename=$(basename "$icui18n_id") 199 | 200 | icui18n_path=$dylib_dir/$icui18n_id_basename 201 | icui18n_path_new=dylib/$icui18n_id_basename 202 | icui18n_id_new=@loader_path/dylib/$icui18n_id_basename 203 | 204 | # copy icui18n to the new directory 205 | cp "$icui18n_path" "$icui18n_path_new" 206 | 207 | # change icui18n's ID referenced by ALS 208 | install_name_tool -change "$icui18n_id" "$icui18n_id_new" "$executable" 209 | 210 | echo "icui18n referenced by ALS" 211 | echo " old ID : $icui18n_id" 212 | echo " new ID : $icui18n_id_new" 213 | echo " old path: $icui18n_path" 214 | echo " new path: $icui18n_path_new" 215 | 216 | ################################################################################ 217 | # icudata 218 | ################################################################################ 219 | 220 | # otool -L "$icui18n_id" | grep icudata | awk '{print $1}' 221 | icudata_id=$(otool -L "$icuuc_path" | grep icudata | awk '{print $1}') 222 | icudata_id_basename=$(basename "$icudata_id") 223 | 224 | icudata_path=$dylib_dir/$icudata_id_basename 225 | icudata_path_new=dylib/$icudata_id_basename 226 | 227 | # copy icudata to the new directory 228 | cp "$icudata_path" "$icudata_path_new" 229 | 230 | # no need of changing the ID because supposely it's already of "@loader_path" 231 | 232 | echo "icudata referenced by icuuc" 233 | echo " old ID : $icudata_id" 234 | echo " old path : $icudata_path" 235 | echo " new path : $icudata_path_new" 236 | 237 | - name: 📦 Bundle executable, DLLs and data files (on Linux and macOS) 238 | if: runner.os != 'Windows' 239 | id: zip 240 | run: | 241 | # locate the data-dir 242 | datadir=$(find "$(stack path $STACK_YAML_ARG --snapshot-install-root)/share" -type d -name "Agda-*") 243 | echo "datadir: $datadir" 244 | 245 | # locate the executable 246 | executable=$(find "$(stack path $STACK_YAML_ARG --local-install-root)/bin" -name "als") 247 | echo "executable: $executable" 248 | 249 | # make a temporary directory for compresssing 250 | mkdir zip 251 | cp -r "$datadir" zip/data 252 | if [[ ${{ runner.os }} == "macOS" ]]; then 253 | cp -r dylib zip/dylib 254 | fi 255 | cp "$executable" zip/ 256 | 257 | # compress 258 | cd zip 259 | zip -r $ARTEFACT.zip ./* 260 | cd .. 261 | mv zip/$ARTEFACT.zip . 262 | 263 | 264 | - name: 📦 Bundle executable, DLLs and data files (on Windows) 265 | if: runner.os == 'Windows' 266 | shell: pwsh 267 | run: | 268 | # locate the data-dir 269 | $snapshot = (stack path $STACK_YAML_ARG --snapshot-install-root) 270 | $datadir = (ls $snapshot\share *Agda-* -Recurse -Directory).FullName 271 | 272 | # locate the executable 273 | $local = (stack path $STACK_YAML_ARG --local-install-root) 274 | $executable = (ls $local\bin *als.exe* -Recurse -File).FullName 275 | 276 | # make a temporary directory for compresssing 277 | mkdir zip 278 | cp -r $datadir zip/data 279 | cp $executable zip/ 280 | 281 | # include text-icu DLLs 282 | $mingw64bin = (stack path $STACK_YAML_ARG --extra-library-dirs).split(", ") -match "\\bin" 283 | cp (ls $mingw64bin *libicudt*) zip/ 284 | cp (ls $mingw64bin *libicuin*) zip/ 285 | cp (ls $mingw64bin *libicuuc*) zip/ 286 | ls zip 287 | 288 | # compress 289 | cd zip 290 | Compress-Archive * "$($env:ARTEFACT).zip" 291 | cd .. 292 | mv zip/"$($env:ARTEFACT).zip" . 293 | 294 | - name: 🧪 Run tests 295 | run: stack test $STACK_YAML_ARG --ta --als-path=zip/als 296 | 297 | # release (optional) 298 | - name: 🚢 Release Artifacts 299 | if: startsWith(github.ref, 'refs/tags/v') # so that only commits with a git tag would upload artifacts 300 | env: 301 | GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }} 302 | run: gh release upload ${{ github.ref_name }} $ARTEFACT.zip --clobber -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .cabal-sandbox/ 2 | .HTF/ 3 | .stack-work/ 4 | cabal-dev 5 | dist 6 | dist-* 7 | node_modules/ 8 | *.o 9 | *.hi 10 | *.log 11 | *.chi 12 | *.chs.h 13 | *.dyn_o 14 | *.dyn_hi 15 | .hpc 16 | .hsenv 17 | *.prof 18 | *.aux 19 | *.hp 20 | *.eventlog 21 | cabal.sandbox.config 22 | cabal.project.local 23 | *~ 24 | 25 | 26 | *.agdai -------------------------------------------------------------------------------- /CHANGELOG.md: -------------------------------------------------------------------------------- 1 | # Changelog 2 | 3 | All notable changes to this project will be documented in this file. 4 | 5 | The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.0.0/). 6 | 7 | ## v0.2.7.0.1.5 - 2024-12-18 8 | 9 | ### Added 10 | - New command line option `--version` and `-V` for printing version information. 11 | 12 | ## v0.2.7.0.1.4 - 2024-12-6 13 | 14 | ### Changed 15 | - Target only 3 versions of Agda at a time: Agda-2.7.0.1, Agda-2.6.4.3, and Agda-2.6.3. 16 | 17 | ## v0.2.7.0.1.3 - 2024-12-5 18 | 19 | ### Fixed 20 | - Add dummy LSP handlers for `initialized`, `workspace/didChangeConfiguration`, `textDocument/didOpen`, `textDocument/didClose`, `textDocument/didChange`, and `textDocument/didSave` to avoid errors in the client. 21 | 22 | ## v0.2.7.0.1.2 - 2024-12-4 23 | 24 | ### Fixed 25 | - Release of artefacts on macOS 26 | 27 | ## v0.2.7.0.1.1 - 2024-12-4 28 | 29 | ### Added 30 | - #29: Integration testing for the language server 31 | - Prebuilt binaries for Intel x64 macOS 32 | - Support for Agda-2.7.0.1 33 | 34 | ### Changed 35 | - Unfied workflow for building and testing the language server across all platforms 36 | 37 | ## v0.2.7.0.1.0 - 2024-12-2 38 | 39 | ### Added 40 | - #22: agda 2.6.4 by [@andreasabel](https://github.com/andreasabel) 41 | - #23: lsp 2 by [@andreasabel](https://github.com/andreasabel) 42 | 43 | ### Fixed 44 | - Version information of the language server 45 | 46 | ## v0.2.6.4.0.3 - 2023-12-14 47 | 48 | ### Fixed 49 | - #15: Add missing handlers for `lsp` methods. 50 | - #24: Fix the encoding of binaries built on GitHub Actions. 51 | - Patch path to the "data" directory when the executable is built on GitHub Actions. 52 | 53 | ## v0.2.6.4.0.0 - 2023-12-12 54 | 55 | ### Changed 56 | - Embed Agda-2.6.4. 57 | - Builds with `lsp` < 1.7 on GHC 9.2 (LTS 20.26), 58 | and with Cabal also on 9.4 and 9.6. 59 | 60 | ### Added 61 | - Build flag `Agda-2-6-3` to embed Agda-2.6.3 rather than 2.6.4. 62 | 63 | 64 | ## v0.2.6.3.0 - 2023-11-23 65 | 66 | ### Changed 67 | - Embed Agda-2.6.3. 68 | - Builds with `lsp` < 1.7 on GHC 8.10 (LTS 18.28), 9.0 (LTS 19.33), and 9.2 (LTS 20.26), 69 | and with Cabal also on 9.4 and 9.6. 70 | 71 | ### Added 72 | - Build flag `Agda-2-6-2-2` to embed Agda-2.6.2.2 rather than 2.6.3. 73 | 74 | 75 | ## v0.2.6.2.2.1 - 2023-11-21 76 | 77 | ### Added 78 | 79 | - Building with `lsp-1.6`. 80 | Builds with `lsp` < 1.7 on GHC 8.10 (LTS 18.28), 9.0 (LTS 19.33), and 9.2 (LTS 20.26). 81 | 82 | 83 | ## v0.2.6.2.2 - 2023-11-21 84 | 85 | ### Changed 86 | 87 | - Embed Agda-2.6.2.2. 88 | - Versioning scheme: _x.a.b.c.d.y_ where _a.b.c.d_ is the 4-digit Agda version (2.6.2.2), _x_ is 0 but may be bumped for revolutionary changes to the agda-language-server, and _y_ is for patch releases. 89 | - Builds with `lsp` < 1.5 on GHC 8.10 (LTS 18.28) and 9.0 (LTS 19.33). 90 | 91 | 92 | ## v0.2.1 - 2021-10-25 93 | 94 | No changes. 95 | 96 | 97 | ## v0.2.0 - 2021-10-22 98 | 99 | ### Fixed 100 | - #2: Allow user to supply command-line options via agda-mode 101 | 102 | 103 | ## v0.1.4 - 2021-10-04 104 | 105 | ### Fixed 106 | - Resume sending HighlightingInfos to agda-mode 107 | 108 | 109 | ## v0.1.3 - 2021-10-04 110 | 111 | ### Fixed 112 | - Include DLLs in the bundle 113 | 114 | 115 | ## v0.1.2 - 2021-10-03 116 | 117 | ### Fixed 118 | - #5: Connection Error 119 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2017 - 2020 Luā Tîng-Giān 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Agda Language Server 2 | 3 | ## Supported versions of Agda 4 | 5 | These are the currently supported versions of Agda: 6 | * Agda-2.7.0.1 7 | * Agda-2.6.4.3 8 | * Agda-2.6.3 9 | 10 | All releases will come with binaries built with these versions of Agda. 11 | 12 | We plan to make the codebase compatible with **at most 3 versions of Agda** at a single time. Because otherwise we'd be drowned by CPP macros for conditional compilation. 13 | 14 | ## Installation 15 | 16 | The simplest way of acquiring Agda Language Server is through [agda-mode on VS Code](https://github.com/banacorn/agda-mode-vscode#agda-language-server). 17 | Follow the instructions and the language server should be installed within seconds. 18 | 19 | ### Prebuilt binaries 20 | 21 | You can also download prebuilt binaries [from the release page](https://github.com/banacorn/agda-language-server/releases) if you are using other LSP-compatible text editors. 22 | 23 | Supported platforms: **Windows**, **Mac**, and **Ubuntu**. 24 | 25 | ### Build from source 26 | 27 | You will need [Haskell Stack](https://docs.haskellstack.org/en/stable/README/) to build the project: 28 | 29 | ``` 30 | stack install 31 | ``` 32 | 33 | ## Versioning 34 | 35 | The version is _x.a.b.c.d.y_ where _a.b.c.d_ is the 4-digit Agda version (2.6.4.0), _x_ is 0 but may be bumped for revolutionary changes to the agda-language-server, and _y_ is for patch releases. 36 | 37 | ## Why make it standalone? 38 | 39 | * for less impact on the Agda codebase 40 | * to help [decouple the Agda codebase](https://github.com/agda/agda/projects/5) 41 | * we can always merge it back to Agda later anyway 42 | 43 | ## Hacking 44 | 45 | This language server is co-developed alongside [agda-mode on VS Code](https://github.com/banacorn/agda-mode-vscode). 46 | Enable `agdaMode.connection.agdaLanguageServer` in agda-mode's settings, and then hit *restart* C-x C-r to connect to the language server. 47 | The editor extension will search for the language server in the following order: 48 | 1. `localhost:4096` via TCP 49 | 2. `als` executable on your machine 50 | 3. Prebuilt binaries on GitHub 51 | 52 | To host the language server locally at `localhost:4096`, run `:main -p` in the REPL (`stack repl`). 53 | This allows us to reload the language server in the REPL without having to recompile and reinstall the whole project on your system every time there is a change. 54 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain -------------------------------------------------------------------------------- /agda-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: agda-language-server 8 | version: 0.2.7.0.1.4 9 | synopsis: An implementation of language server protocal (LSP) for Agda 2. 10 | description: Please see the README on GitHub at 11 | category: Development 12 | homepage: https://github.com/banacorn/agda-language-server#readme 13 | bug-reports: https://github.com/banacorn/agda-language-server/issues 14 | author: Ting-Gian LUA 15 | maintainer: banacorn@gmail.com, Andreas Abel 16 | copyright: 2020-23 Ting-Gian LUA, Andreas ABEL 17 | license: MIT 18 | license-file: LICENSE 19 | build-type: Simple 20 | extra-source-files: 21 | README.md 22 | CHANGELOG.md 23 | package.yaml 24 | stack.yaml 25 | stack-9.2-Agda-2.6.3.yaml 26 | stack-9.2-Agda-2.6.4.3.yaml 27 | stack-9.2-Agda-2.7.0.1.yaml 28 | 29 | source-repository head 30 | type: git 31 | location: https://github.com/banacorn/agda-language-server 32 | 33 | flag Agda-2-6-3 34 | description: Embed Agda-2.6.3 35 | manual: True 36 | default: False 37 | 38 | flag Agda-2-6-4-3 39 | description: Embed Agda-2.6.4.3 40 | manual: True 41 | default: False 42 | 43 | flag Agda-2-7-0-1 44 | description: Embed Agda-2.7.0.1 45 | manual: True 46 | default: False 47 | 48 | library 49 | exposed-modules: 50 | Agda 51 | Agda.Convert 52 | Agda.IR 53 | Agda.Parser 54 | Agda.Position 55 | Control.Concurrent.SizedChan 56 | Monad 57 | Options 58 | Render 59 | Render.Class 60 | Render.Common 61 | Render.Concrete 62 | Render.Interaction 63 | Render.Internal 64 | Render.Literal 65 | Render.Name 66 | Render.Position 67 | Render.RichText 68 | Render.TypeChecking 69 | Render.Utils 70 | Server 71 | Server.CommandController 72 | Server.Handler 73 | Server.ResponseController 74 | Switchboard 75 | other-modules: 76 | Paths_agda_language_server 77 | hs-source-dirs: 78 | src 79 | default-extensions: 80 | LambdaCase 81 | OverloadedStrings 82 | PatternSynonyms 83 | TypeOperators 84 | ghc-options: -Wincomplete-patterns -Wunused-do-bind -Wunused-foralls -Wwarnings-deprecations -Wwrong-do-bind -Wmissing-fields -Wmissing-methods -Wmissing-pattern-synonym-signatures -Wmissing-signatures -Werror=incomplete-patterns -fno-warn-orphans 85 | build-depends: 86 | Agda 87 | , aeson 88 | , base >=4.7 && <5 89 | , bytestring 90 | , containers 91 | , directory 92 | , filepath 93 | , lsp >=2 94 | , lsp-types >=2 95 | , mtl 96 | , network 97 | , network-simple 98 | , prettyprinter 99 | , process 100 | , stm 101 | , strict 102 | , text 103 | , text-icu 104 | default-language: Haskell2010 105 | if flag(Agda-2-6-3) 106 | build-depends: 107 | Agda ==2.6.3 108 | if flag(Agda-2-6-4-3) 109 | build-depends: 110 | Agda ==2.6.4.3 111 | if flag(Agda-2-7-0-1) 112 | build-depends: 113 | Agda ==2.7.0.1 114 | 115 | executable als 116 | main-is: Main.hs 117 | other-modules: 118 | Paths_agda_language_server 119 | hs-source-dirs: 120 | app 121 | default-extensions: 122 | LambdaCase 123 | OverloadedStrings 124 | PatternSynonyms 125 | TypeOperators 126 | ghc-options: -Wincomplete-patterns -Wunused-do-bind -Wunused-foralls -Wwarnings-deprecations -Wwrong-do-bind -Wmissing-fields -Wmissing-methods -Wmissing-pattern-synonym-signatures -Wmissing-signatures -threaded -rtsopts -with-rtsopts=-N -Werror=incomplete-patterns -fno-warn-orphans 127 | build-depends: 128 | Agda 129 | , aeson 130 | , agda-language-server 131 | , base >=4.7 && <5 132 | , bytestring 133 | , containers 134 | , directory 135 | , filepath 136 | , lsp >=2 137 | , lsp-types >=2 138 | , mtl 139 | , network 140 | , network-simple 141 | , prettyprinter 142 | , process 143 | , stm 144 | , strict 145 | , text 146 | , text-icu 147 | default-language: Haskell2010 148 | if flag(Agda-2-6-3) 149 | build-depends: 150 | Agda ==2.6.3 151 | if flag(Agda-2-6-4-3) 152 | build-depends: 153 | Agda ==2.6.4.3 154 | if flag(Agda-2-7-0-1) 155 | build-depends: 156 | Agda ==2.7.0.1 157 | 158 | test-suite als-test 159 | type: exitcode-stdio-1.0 160 | main-is: Test.hs 161 | other-modules: 162 | Test.LSP 163 | Test.SrcLoc 164 | Agda 165 | Agda.Convert 166 | Agda.IR 167 | Agda.Parser 168 | Agda.Position 169 | Control.Concurrent.SizedChan 170 | Monad 171 | Options 172 | Render 173 | Render.Class 174 | Render.Common 175 | Render.Concrete 176 | Render.Interaction 177 | Render.Internal 178 | Render.Literal 179 | Render.Name 180 | Render.Position 181 | Render.RichText 182 | Render.TypeChecking 183 | Render.Utils 184 | Server 185 | Server.CommandController 186 | Server.Handler 187 | Server.ResponseController 188 | Switchboard 189 | Paths_agda_language_server 190 | hs-source-dirs: 191 | test 192 | src 193 | default-extensions: 194 | LambdaCase 195 | OverloadedStrings 196 | PatternSynonyms 197 | TypeOperators 198 | ghc-options: -Wincomplete-patterns -Wunused-do-bind -Wunused-foralls -Wwarnings-deprecations -Wwrong-do-bind -Wmissing-fields -Wmissing-methods -Wmissing-pattern-synonym-signatures -Wmissing-signatures -threaded -rtsopts -with-rtsopts=-N -Werror=incomplete-patterns -fno-warn-orphans 199 | build-depends: 200 | Agda 201 | , aeson 202 | , base >=4.7 && <5 203 | , bytestring 204 | , containers 205 | , directory 206 | , filepath 207 | , lsp >=2 208 | , lsp-test 209 | , lsp-types >=2 210 | , mtl 211 | , network 212 | , network-simple 213 | , prettyprinter 214 | , process 215 | , stm 216 | , strict 217 | , tasty 218 | , tasty-golden 219 | , tasty-hunit 220 | , tasty-quickcheck 221 | , text 222 | , text-icu 223 | default-language: Haskell2010 224 | if flag(Agda-2-6-3) 225 | build-depends: 226 | Agda ==2.6.3 227 | if flag(Agda-2-6-4-3) 228 | build-depends: 229 | Agda ==2.6.4.3 230 | if flag(Agda-2-7-0-1) 231 | build-depends: 232 | Agda ==2.7.0.1 233 | -------------------------------------------------------------------------------- /app/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Control.Monad (when) 4 | import Options 5 | import Server (run) 6 | -- import Simple (run) 7 | import System.Console.GetOpt 8 | import System.Directory (doesDirectoryExist) 9 | import System.Environment 10 | import System.FilePath (()) 11 | import System.IO 12 | import Text.Read (readMaybe) 13 | 14 | main :: IO () 15 | main = do 16 | -- set locale to UTF-8 17 | -- https://github.com/agda/agda-language-server/issues/24 18 | hSetEncoding stdout utf8 19 | hSetEncoding stdin utf8 20 | hSetEncoding stderr utf8 21 | 22 | -- The GitHub CI-built executable lacks the correct data directory path. 23 | -- If there's directory named "data" in the executable's directory, 24 | -- then we assume that the executable is built by GitHub CI 25 | -- and we should set the $Agda_datadir environment variable to the correct directory. 26 | executablePath <- getExecutablePath 27 | let dataDir = executablePath "data" 28 | isBuiltByCI <- doesDirectoryExist dataDir 29 | when isBuiltByCI $ do 30 | setEnv "Agda_datadir" dataDir 31 | 32 | options <- getOptionsFromArgv 33 | if optHelp options 34 | then putStrLn usageMessage 35 | else 36 | if optVersion options 37 | then putStrLn versionString 38 | else do 39 | _ <- run options 40 | -- _ <- run 41 | return () -------------------------------------------------------------------------------- /hie.yaml: -------------------------------------------------------------------------------- 1 | cradle: 2 | stack: 3 | - path: "./src" 4 | component: "agda-language-server:lib" 5 | 6 | - path: "./app/Main.hs" 7 | component: "agda-language-server:exe:als" 8 | 9 | - path: "./app/Paths_agda_language_server.hs" 10 | component: "agda-language-server:exe:als" 11 | 12 | - path: "./test" 13 | component: "agda-language-server:test:als-test" 14 | -------------------------------------------------------------------------------- /package.yaml: -------------------------------------------------------------------------------- 1 | name: agda-language-server 2 | version: 0.2.7.0.1.5 3 | github: "banacorn/agda-language-server" 4 | license: MIT 5 | author: "Ting-Gian LUA" 6 | maintainer: "banacorn@gmail.com, Andreas Abel" 7 | copyright: "2020-23 Ting-Gian LUA, Andreas ABEL" 8 | 9 | extra-source-files: 10 | - README.md 11 | - CHANGELOG.md 12 | - package.yaml 13 | - stack.yaml 14 | - stack-9.2-Agda-2.6.3.yaml 15 | - stack-9.2-Agda-2.6.4.3.yaml 16 | - stack-9.2-Agda-2.7.0.1.yaml 17 | 18 | # Metadata used when publishing your package 19 | synopsis: An implementation of language server protocal (LSP) for Agda 2. 20 | category: Development 21 | 22 | # To avoid duplicated efforts in documentation and dealing with the 23 | # complications of embedding Haddock markup inside cabal files, it is 24 | # common to point users to the README.md file. 25 | description: Please see the README on GitHub at 26 | 27 | flags: 28 | Agda-2-6-3: 29 | description: Embed Agda-2.6.3 30 | manual: true 31 | default: false 32 | Agda-2-6-4-3: 33 | description: Embed Agda-2.6.4.3 34 | manual: true 35 | default: false 36 | Agda-2-7-0-1: 37 | description: Embed Agda-2.7.0.1 38 | manual: true 39 | default: false 40 | 41 | when: 42 | - condition: "flag(Agda-2-6-3)" 43 | dependencies: 44 | - Agda == 2.6.3 45 | - condition: "flag(Agda-2-6-4-3)" 46 | dependencies: 47 | - Agda == 2.6.4.3 48 | - condition: "flag(Agda-2-7-0-1)" 49 | dependencies: 50 | - Agda == 2.7.0.1 51 | # - condition: "flag(Agda-2-6-2-2) && flag(Agda-2-6-3)" 52 | # dependencies: 53 | # - Agda < 0 54 | 55 | dependencies: 56 | - base >= 4.7 && < 5 57 | - Agda 58 | - aeson 59 | - bytestring 60 | - containers 61 | - directory 62 | - filepath 63 | - lsp-types >= 2 64 | - lsp >= 2 65 | - mtl 66 | - network 67 | - network-simple 68 | - strict 69 | - stm 70 | - text 71 | - text-icu 72 | - process 73 | - prettyprinter 74 | 75 | default-extensions: 76 | - LambdaCase 77 | - OverloadedStrings 78 | - PatternSynonyms 79 | - TypeOperators 80 | 81 | library: 82 | source-dirs: src 83 | ghc-options: 84 | - -Wincomplete-patterns 85 | - -Wunused-do-bind 86 | - -Wunused-foralls 87 | - -Wwarnings-deprecations 88 | - -Wwrong-do-bind 89 | - -Wmissing-fields 90 | - -Wmissing-methods 91 | - -Wmissing-pattern-synonym-signatures 92 | - -Wmissing-signatures 93 | - -Werror=incomplete-patterns 94 | - -fno-warn-orphans 95 | 96 | executables: 97 | als: 98 | main: Main.hs 99 | source-dirs: app 100 | ghc-options: 101 | - -Wincomplete-patterns 102 | - -Wunused-do-bind 103 | - -Wunused-foralls 104 | - -Wwarnings-deprecations 105 | - -Wwrong-do-bind 106 | - -Wmissing-fields 107 | - -Wmissing-methods 108 | - -Wmissing-pattern-synonym-signatures 109 | - -Wmissing-signatures 110 | - -threaded 111 | - -rtsopts 112 | - -with-rtsopts=-N 113 | - -Werror=incomplete-patterns 114 | - -fno-warn-orphans 115 | dependencies: 116 | - agda-language-server 117 | 118 | tests: 119 | als-test: 120 | main: Test.hs 121 | source-dirs: 122 | - test 123 | - src 124 | dependencies: 125 | - lsp-test 126 | - tasty 127 | - tasty-hunit 128 | - tasty-golden 129 | - tasty-quickcheck 130 | 131 | ghc-options: 132 | - -Wincomplete-patterns 133 | - -Wunused-do-bind 134 | - -Wunused-foralls 135 | - -Wwarnings-deprecations 136 | - -Wwrong-do-bind 137 | - -Wmissing-fields 138 | - -Wmissing-methods 139 | - -Wmissing-pattern-synonym-signatures 140 | - -Wmissing-signatures 141 | - -threaded 142 | - -rtsopts 143 | - -with-rtsopts=-N 144 | - -Werror=incomplete-patterns 145 | - -fno-warn-orphans 146 | 147 | # tests: 148 | # als-test: 149 | # main: Spec.hs 150 | # source-dirs: test 151 | # ghc-options: 152 | # - -threaded 153 | # - -rtsopts 154 | # - -with-rtsopts=-N 155 | # dependencies: 156 | # - agda-language-server 157 | -------------------------------------------------------------------------------- /src/Agda.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wno-missing-methods #-} 2 | 3 | {-# LANGUAGE CPP #-} 4 | {-# LANGUAGE DeriveGeneric #-} 5 | 6 | module Agda 7 | ( start 8 | , runAgda 9 | , sendCommand 10 | , getCommandLineOptions 11 | , CommandReq(..) 12 | , CommandRes(..) 13 | ) where 14 | 15 | import Prelude hiding ( null ) 16 | 17 | import Agda.Compiler.Backend ( parseBackendOptions ) 18 | import Agda.Compiler.Builtin ( builtinBackends ) 19 | import Agda.Convert ( fromResponse ) 20 | import Agda.Interaction.Base ( Command 21 | , Command'(Command, Done, Error) 22 | #if MIN_VERSION_Agda(2,7,0) 23 | #else 24 | , CommandM 25 | #endif 26 | , CommandState(optionsOnReload) 27 | , IOTCM 28 | , initCommandState 29 | , parseIOTCM 30 | ) 31 | #if MIN_VERSION_Agda(2,6,4) 32 | import Agda.Syntax.Common.Pretty ( render, vcat ) 33 | #endif 34 | import Agda.Interaction.InteractionTop 35 | ( initialiseCommandQueue 36 | , maybeAbort 37 | , runInteraction 38 | #if MIN_VERSION_Agda(2,7,0) 39 | , CommandM 40 | #else 41 | #endif 42 | ) 43 | import Agda.Interaction.Options ( CommandLineOptions 44 | ( optAbsoluteIncludePaths 45 | ) 46 | , defaultOptions 47 | , runOptM 48 | ) 49 | import Agda.TypeChecking.Errors ( getAllWarningsOfTCErr 50 | , prettyError 51 | , prettyTCWarnings' 52 | ) 53 | import Agda.TypeChecking.Monad ( HasOptions 54 | , TCErr 55 | , commandLineOptions 56 | , runTCMTop' 57 | ) 58 | import Agda.TypeChecking.Monad.Base ( TCM ) 59 | import qualified Agda.TypeChecking.Monad.Benchmark 60 | as Bench 61 | import Agda.TypeChecking.Monad.State ( setInteractionOutputCallback ) 62 | import Agda.Utils.FileName ( absolute ) 63 | import Agda.Utils.Impossible ( CatchImpossible 64 | ( catchImpossible 65 | ) 66 | , Impossible 67 | ) 68 | import Agda.Utils.Null ( null ) 69 | import Agda.VersionCommit ( versionWithCommitInfo ) 70 | import Control.Exception ( SomeException 71 | , catch 72 | ) 73 | import Control.Monad 74 | import Control.Monad.Except 75 | import Control.Monad.Reader 76 | import Control.Monad.State 77 | import Data.Aeson ( FromJSON 78 | , ToJSON(toJSON) 79 | , Value 80 | , fromJSON 81 | ) 82 | import qualified Data.Aeson as JSON 83 | import Data.Maybe ( listToMaybe ) 84 | import Data.Text ( pack ) 85 | import GHC.Generics ( Generic ) 86 | import Language.LSP.Server ( getConfig ) 87 | import Monad 88 | import Options ( Config(configRawAgdaOptions) 89 | , Options(optRawAgdaOptions) 90 | ) 91 | 92 | getAgdaVersion :: String 93 | getAgdaVersion = versionWithCommitInfo 94 | 95 | start :: ServerM IO () 96 | start = do 97 | env <- ask 98 | 99 | writeLog "[Agda] interaction start" 100 | 101 | result <- runAgda $ do 102 | -- decides how to output Response 103 | lift $ setInteractionOutputCallback $ \response -> do 104 | reaction <- fromResponse response 105 | sendResponse env reaction 106 | 107 | -- keep reading command 108 | commands <- liftIO $ initialiseCommandQueue (readCommand env) 109 | 110 | -- get command line options 111 | options <- getCommandLineOptions 112 | 113 | -- start the loop 114 | let commandState = (initCommandState commands) 115 | { optionsOnReload = options { optAbsoluteIncludePaths = [] } 116 | } 117 | 118 | _ <- mapReaderT (`runStateT` commandState) (loop env) 119 | 120 | return () 121 | -- TODO: we should examine the result 122 | case result of 123 | Left _err -> return () 124 | Right _val -> return () 125 | where 126 | loop :: Env -> ServerM CommandM () 127 | loop env = do 128 | Bench.reset 129 | done <- Bench.billTo [] $ do 130 | r <- lift $ maybeAbort runInteraction 131 | case r of 132 | Done -> return True -- Done. 133 | Error s -> do 134 | writeLog ("Error " <> pack s) 135 | return False 136 | Command _ -> do 137 | writeLog "[Response] Finished sending, waiting for them to complete" 138 | waitUntilResponsesSent 139 | signalCommandFinish 140 | return False 141 | 142 | lift Bench.print 143 | unless done (loop env) 144 | 145 | -- Reads the next command from the Channel 146 | readCommand :: Env -> IO Command 147 | readCommand env = Command <$> consumeCommand env 148 | 149 | -------------------------------------------------------------------------------- 150 | 151 | -- | Convert "CommandReq" to "CommandRes" 152 | 153 | sendCommand :: MonadIO m => Value -> ServerM m Value 154 | sendCommand value = do 155 | -- JSON Value => Request => Response 156 | case fromJSON value of 157 | JSON.Error msg -> 158 | return 159 | $ toJSON 160 | $ CmdRes 161 | $ Just 162 | $ CmdErrCannotDecodeJSON 163 | $ show msg 164 | ++ "\n" 165 | ++ show value 166 | JSON.Success request -> toJSON <$> handleCommandReq request 167 | 168 | 169 | handleCommandReq :: MonadIO m => CommandReq -> ServerM m CommandRes 170 | handleCommandReq CmdReqSYN = return $ CmdResACK Agda.getAgdaVersion 171 | handleCommandReq (CmdReq cmd) = do 172 | case parseIOTCM cmd of 173 | Left err -> do 174 | writeLog $ "[Error] CmdErrCannotParseCommand:\n" <> pack err 175 | return $ CmdRes (Just (CmdErrCannotParseCommand err)) 176 | Right iotcm -> do 177 | writeLog $ "[Request] " <> pack (show cmd) 178 | provideCommand iotcm 179 | return $ CmdRes Nothing 180 | 181 | -------------------------------------------------------------------------------- 182 | 183 | getCommandLineOptions 184 | :: (HasOptions m, MonadIO m) => ServerM m CommandLineOptions 185 | getCommandLineOptions = do 186 | -- command line options from ARGV 187 | argv <- asks (optRawAgdaOptions . envOptions) 188 | -- command line options from agda-mode 189 | config <- asks (configRawAgdaOptions . envConfig) 190 | -- concatenate both 191 | let merged = argv <> config 192 | 193 | result <- runExceptT $ do 194 | let p = parseBackendOptions builtinBackends merged defaultOptions 195 | let (r, _warns) = runOptM p 196 | (bs, opts) <- ExceptT $ pure r 197 | return opts 198 | case result of 199 | -- something bad happened, use the default options instead 200 | Left _ -> commandLineOptions 201 | Right opts -> return opts 202 | 203 | -- | Run a TCM action in IO and throw away all of the errors 204 | -- TODO: handle the caught errors 205 | runAgda :: MonadIO m => ServerM TCM a -> ServerM m (Either String a) 206 | runAgda p = do 207 | env <- ask 208 | let p' = runServerM env p 209 | liftIO 210 | $ runTCMTop' 211 | ( (Right <$> p') 212 | `catchError` handleTCErr 213 | `catchImpossible` handleImpossible 214 | ) 215 | `catch` catchException 216 | where 217 | handleTCErr :: TCErr -> TCM (Either String a) 218 | handleTCErr err = do 219 | s2s <- prettyTCWarnings' =<< getAllWarningsOfTCErr err 220 | s1 <- prettyError err 221 | let ss = filter (not . null) $ s2s ++ [s1] 222 | #if MIN_VERSION_Agda(2,6,4) 223 | let errorMsg = render $ vcat ss 224 | #else 225 | let errorMsg = unlines ss 226 | #endif 227 | return (Left errorMsg) 228 | 229 | handleImpossible :: Impossible -> TCM (Either String a) 230 | handleImpossible = return . Left . show 231 | 232 | catchException :: SomeException -> IO (Either String a) 233 | catchException e = return $ Left $ show e 234 | 235 | -------------------------------------------------------------------------------- 236 | 237 | data CommandReq 238 | = CmdReqSYN -- ^ For client to initiate a 2-way handshake 239 | | CmdReq String 240 | deriving (Generic) 241 | 242 | instance ToJSON CommandReq 243 | instance FromJSON CommandReq 244 | 245 | data CommandRes 246 | = CmdResACK -- ^ For server to complete a 2-way handshake 247 | String -- ^ Version number of Agda 248 | | CmdRes -- ^ Response for 'CmdReq' 249 | (Maybe CommandErr) -- ^ 'Nothing' to indicate success 250 | deriving (Generic) 251 | 252 | instance ToJSON CommandRes 253 | 254 | data CommandErr 255 | = CmdErrCannotDecodeJSON String 256 | | CmdErrCannotParseCommand String 257 | deriving (Generic) 258 | 259 | instance ToJSON CommandErr 260 | -------------------------------------------------------------------------------- /src/Agda/Convert.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | 3 | module Agda.Convert where 4 | 5 | import Agda.IR (FromAgda (..)) 6 | import qualified Agda.IR as IR 7 | import Agda.Interaction.Base 8 | import Agda.Interaction.BasicOps as B 9 | import Agda.Interaction.EmacsCommand (Lisp) 10 | import Agda.Interaction.EmacsTop (showInfoError) 11 | import Agda.Interaction.Highlighting.Common (chooseHighlightingMethod, toAtoms) 12 | import Agda.Interaction.Highlighting.Precise (Aspects (..), DefinitionSite (..), HighlightingInfo, TokenBased (..)) 13 | import qualified Agda.Interaction.Highlighting.Range as Highlighting 14 | import Agda.Interaction.InteractionTop (localStateCommandM) 15 | #if MIN_VERSION_Agda(2,7,0) 16 | import Agda.Interaction.Output ( OutputConstraint ) 17 | #endif 18 | import Agda.Interaction.Response as R 19 | import Agda.Syntax.Abstract as A 20 | import Agda.Syntax.Abstract.Pretty (prettyATop) 21 | import Agda.Syntax.Common 22 | import Agda.Syntax.Concrete as C 23 | import Agda.Syntax.Internal (alwaysUnblock) 24 | import Agda.Syntax.Position (HasRange (getRange), Range, noRange) 25 | import Agda.Syntax.Scope.Base 26 | import Agda.TypeChecking.Errors (explainWhyInScope, getAllWarningsOfTCErr, prettyError) 27 | import Agda.TypeChecking.Monad hiding (Function) 28 | import Agda.TypeChecking.Monad.MetaVars (withInteractionId) 29 | import Agda.TypeChecking.Pretty (prettyTCM) 30 | import qualified Agda.TypeChecking.Pretty as TCP 31 | import Agda.TypeChecking.Pretty.Warning (filterTCWarnings, prettyTCWarnings, prettyTCWarnings') 32 | import Agda.TypeChecking.Warnings (WarningsAndNonFatalErrors (..)) 33 | import Agda.Utils.FileName (filePath) 34 | import Agda.Utils.Function (applyWhen) 35 | import Agda.Utils.IO.TempFile (writeToTempFile) 36 | import Agda.Utils.Impossible (__IMPOSSIBLE__) 37 | import Agda.Utils.Maybe (catMaybes) 38 | import Agda.Utils.Null (empty) 39 | import Agda.Utils.RangeMap (IsBasicRangeMap (toList)) 40 | import Agda.Utils.String (delimiter) 41 | import Agda.Utils.Time (CPUTime) 42 | import Agda.VersionCommit (versionWithCommitInfo) 43 | import Control.Monad 44 | import Control.Monad.State hiding (state) 45 | import qualified Data.Aeson as JSON 46 | import qualified Data.ByteString.Lazy.Char8 as BS8 47 | import qualified Data.List as List 48 | import qualified Data.Map as Map 49 | import Data.String (IsString) 50 | import Render (Block (..), Inlines, Render (..), renderATop) 51 | import qualified Render 52 | 53 | #if MIN_VERSION_Agda(2,6,4) 54 | import Agda.Syntax.Common.Pretty hiding (render) 55 | import qualified Prettyprinter 56 | #else 57 | import Agda.Utils.Pretty hiding (render) 58 | #endif 59 | 60 | responseAbbr :: (IsString a) => Response -> a 61 | responseAbbr res = case res of 62 | Resp_HighlightingInfo {} -> "Resp_HighlightingInfo" 63 | Resp_Status {} -> "Resp_Status" 64 | Resp_JumpToError {} -> "Resp_JumpToError" 65 | Resp_InteractionPoints {} -> "Resp_InteractionPoints" 66 | Resp_GiveAction {} -> "Resp_GiveAction" 67 | Resp_MakeCase {} -> "Resp_MakeCase" 68 | Resp_SolveAll {} -> "Resp_SolveAll" 69 | #if MIN_VERSION_Agda(2,7,0) 70 | Resp_Mimer {} -> "Resp_Mimer" 71 | #endif 72 | Resp_DisplayInfo {} -> "Resp_DisplayInfo" 73 | Resp_RunningInfo {} -> "Resp_RunningInfo" 74 | Resp_ClearRunningInfo {} -> "Resp_ClearRunningInfo" 75 | Resp_ClearHighlighting {} -> "Resp_ClearHighlighting" 76 | Resp_DoneAborting {} -> "Resp_DoneAborting" 77 | Resp_DoneExiting {} -> "Resp_DoneExiting" 78 | 79 | ---------------------------------- 80 | 81 | serialize :: Lisp String -> String 82 | serialize = show . pretty 83 | 84 | fromResponse :: Response -> TCM IR.Response 85 | fromResponse (Resp_HighlightingInfo info remove method modFile) = 86 | fromHighlightingInfo info remove method modFile 87 | fromResponse (Resp_DisplayInfo info) = IR.ResponseDisplayInfo <$> fromDisplayInfo info 88 | fromResponse (Resp_ClearHighlighting TokenBased) = return IR.ResponseClearHighlightingTokenBased 89 | fromResponse (Resp_ClearHighlighting NotOnlyTokenBased) = return IR.ResponseClearHighlightingNotOnlyTokenBased 90 | fromResponse Resp_DoneAborting = return IR.ResponseDoneAborting 91 | fromResponse Resp_DoneExiting = return IR.ResponseDoneExiting 92 | fromResponse Resp_ClearRunningInfo = return IR.ResponseClearRunningInfo 93 | fromResponse (Resp_RunningInfo n s) = return $ IR.ResponseRunningInfo n s 94 | fromResponse (Resp_Status s) = return $ IR.ResponseStatus (sChecked s) (sShowImplicitArguments s) 95 | fromResponse (Resp_JumpToError f p) = return $ IR.ResponseJumpToError f (fromIntegral p) 96 | fromResponse (Resp_InteractionPoints is) = 97 | return $ IR.ResponseInteractionPoints (fmap interactionId is) 98 | fromResponse (Resp_GiveAction (InteractionId i) giveAction) = 99 | return $ IR.ResponseGiveAction i (fromAgda giveAction) 100 | fromResponse (Resp_MakeCase _ Function pcs) = return $ IR.ResponseMakeCaseFunction pcs 101 | fromResponse (Resp_MakeCase _ ExtendedLambda pcs) = return $ IR.ResponseMakeCaseExtendedLambda pcs 102 | #if MIN_VERSION_Agda(2,7,0) 103 | fromResponse (Resp_Mimer (InteractionId i) s) = return $ IR.ResponseMimer i s 104 | #endif 105 | fromResponse (Resp_SolveAll ps) = return $ IR.ResponseSolveAll (fmap prn ps) 106 | where 107 | prn (InteractionId i, e) = (i, prettyShow e) 108 | 109 | fromHighlightingInfo :: 110 | HighlightingInfo -> 111 | RemoveTokenBasedHighlighting -> 112 | HighlightingMethod -> 113 | ModuleToSource -> 114 | TCM IR.Response 115 | fromHighlightingInfo h remove method modFile = 116 | case chooseHighlightingMethod h method of 117 | Direct -> return $ IR.ResponseHighlightingInfoDirect info 118 | Indirect -> IR.ResponseHighlightingInfoIndirect <$> indirect 119 | where 120 | fromAspects :: 121 | (Highlighting.Range, Aspects) -> 122 | IR.HighlightingInfo 123 | fromAspects (range, aspects) = 124 | IR.HighlightingInfo 125 | (Highlighting.from range) 126 | (Highlighting.to range) 127 | (toAtoms aspects) 128 | (tokenBased aspects == TokenBased) 129 | (note aspects) 130 | (defSite <$> definitionSite aspects) 131 | where 132 | defSite (DefinitionSite moduleName offset _ _) = 133 | (filePath (Map.findWithDefault __IMPOSSIBLE__ moduleName modFile), offset) 134 | 135 | infos :: [IR.HighlightingInfo] 136 | infos = fmap fromAspects (toList h) 137 | 138 | keepHighlighting :: Bool 139 | keepHighlighting = 140 | case remove of 141 | RemoveHighlighting -> False 142 | KeepHighlighting -> True 143 | 144 | info :: IR.HighlightingInfos 145 | info = IR.HighlightingInfos keepHighlighting infos 146 | 147 | indirect :: TCM FilePath 148 | indirect = liftIO $ writeToTempFile (BS8.unpack (JSON.encode info)) 149 | 150 | fromDisplayInfo :: DisplayInfo -> TCM IR.DisplayInfo 151 | fromDisplayInfo = \case 152 | Info_CompilationOk _ ws -> do 153 | -- filter 154 | let filteredWarnings = filterTCWarnings (tcWarnings ws) 155 | let filteredErrors = filterTCWarnings (nonFatalErrors ws) 156 | -- serializes 157 | warnings <- mapM prettyTCM filteredWarnings 158 | errors <- mapM prettyTCM filteredErrors 159 | return $ IR.DisplayInfoCompilationOk (fmap show warnings) (fmap show errors) 160 | Info_Constraints s -> do 161 | -- constraints <- forM s $ \e -> do 162 | -- rendered <- renderTCM e 163 | -- let raw = show (pretty e) 164 | -- return $ Unlabeled rendered (Just raw) 165 | -- return $ IR.DisplayInfoGeneric "Constraints" constraints 166 | return $ IR.DisplayInfoGeneric "Constraints" [Unlabeled (Render.text $ show $ vcat $ fmap pretty s) Nothing Nothing] 167 | Info_AllGoalsWarnings (ims, hms) ws -> do 168 | -- visible metas (goals) 169 | goals <- mapM convertGoal ims 170 | -- hidden (unsolved) metas 171 | metas <- mapM convertHiddenMeta hms 172 | 173 | -- errors / warnings 174 | -- filter 175 | let filteredWarnings = filterTCWarnings (tcWarnings ws) 176 | let filteredErrors = filterTCWarnings (nonFatalErrors ws) 177 | -- serializes 178 | warnings <- mapM prettyTCM filteredWarnings 179 | errors <- mapM prettyTCM filteredErrors 180 | 181 | let isG = not (null goals && null metas) 182 | let isW = not $ null warnings 183 | let isE = not $ null errors 184 | let title = 185 | List.intercalate "," $ 186 | catMaybes 187 | [ " Goals" <$ guard isG, 188 | " Errors" <$ guard isE, 189 | " Warnings" <$ guard isW, 190 | " Done" <$ guard (not (isG || isW || isE)) 191 | ] 192 | 193 | return $ IR.DisplayInfoAllGoalsWarnings ("*All" ++ title ++ "*") goals metas (fmap show warnings) (fmap show errors) 194 | where 195 | convertHiddenMeta :: OutputConstraint A.Expr NamedMeta -> TCM Block 196 | convertHiddenMeta m = do 197 | let i = nmid $ namedMetaOf m 198 | -- output constrain 199 | meta <- withMetaId i $ renderATop m 200 | serialized <- show <$> withMetaId i (prettyATop m) 201 | -- range 202 | range <- getMetaRange i 203 | 204 | return $ Unlabeled meta (Just serialized) (Just range) 205 | 206 | convertGoal :: OutputConstraint A.Expr InteractionId -> TCM Block 207 | convertGoal i = do 208 | -- output constrain 209 | goal <- 210 | withInteractionId (outputFormId $ OutputForm noRange [] alwaysUnblock i) $ 211 | renderATop i 212 | 213 | serialized <- 214 | withInteractionId (outputFormId $ OutputForm noRange [] alwaysUnblock i) $ 215 | prettyATop i 216 | return $ Unlabeled goal (Just $ show serialized) Nothing 217 | Info_Auto s -> return $ IR.DisplayInfoAuto s 218 | Info_Error err -> do 219 | s <- showInfoError err 220 | return $ IR.DisplayInfoError s 221 | Info_Time s -> 222 | return $ IR.DisplayInfoTime (show (prettyTimed s)) 223 | Info_NormalForm state cmode time expr -> do 224 | exprDoc <- evalStateT prettyExpr state 225 | let doc = maybe empty prettyTimed time $$ exprDoc 226 | return $ IR.DisplayInfoNormalForm (show doc) 227 | where 228 | prettyExpr = 229 | localStateCommandM $ 230 | lift $ 231 | B.atTopLevel $ 232 | allowNonTerminatingReductions $ 233 | (if computeIgnoreAbstract cmode then ignoreAbstractMode else inConcreteMode) $ 234 | B.showComputed cmode expr 235 | Info_InferredType state time expr -> do 236 | renderedExpr <- 237 | flip evalStateT state $ 238 | localStateCommandM $ 239 | lift $ 240 | B.atTopLevel $ 241 | Render.renderA expr 242 | let rendered = case time of 243 | Nothing -> renderedExpr 244 | -- TODO: handle this newline 245 | Just t -> "Time:" Render.<+> Render.render t Render.<+> "\n" Render.<+> renderedExpr 246 | exprDoc <- 247 | flip evalStateT state $ 248 | localStateCommandM $ 249 | lift $ 250 | B.atTopLevel $ 251 | TCP.prettyA expr 252 | let raw = show $ maybe empty prettyTimed time $$ exprDoc 253 | return $ IR.DisplayInfoGeneric "Inferred Type" [Unlabeled rendered (Just raw) Nothing] 254 | Info_ModuleContents modules tel types -> do 255 | doc <- localTCState $ do 256 | typeDocs <- addContext tel $ 257 | forM types $ \(x, t) -> do 258 | doc <- prettyTCM t 259 | return (prettyShow x, ":" <+> doc) 260 | return $ 261 | vcat 262 | [ "Modules", 263 | nest 2 $ vcat $ fmap pretty modules, 264 | "Names", 265 | nest 2 $ align 10 typeDocs 266 | ] 267 | return $ IR.DisplayInfoGeneric "Module contents" [Unlabeled (Render.text $ show doc) Nothing Nothing] 268 | Info_SearchAbout hits names -> do 269 | hitDocs <- forM hits $ \(x, t) -> do 270 | doc <- prettyTCM t 271 | return (prettyShow x, ":" <+> doc) 272 | let doc = 273 | "Definitions about" 274 | <+> text (List.intercalate ", " $ words names) 275 | $$ nest 2 (align 10 hitDocs) 276 | return $ IR.DisplayInfoGeneric "Search About" [Unlabeled (Render.text $ show doc) Nothing Nothing] 277 | Info_WhyInScope why -> do 278 | doc <- explainWhyInScope why 279 | return $ IR.DisplayInfoGeneric "Scope Info" [Unlabeled (Render.text $ show doc) Nothing Nothing] 280 | Info_Context ii ctx -> do 281 | doc <- localTCState (prettyResponseContexts ii False ctx) 282 | return $ IR.DisplayInfoGeneric "Context" [Unlabeled (Render.text $ show doc) Nothing Nothing] 283 | Info_Intro_NotFound -> 284 | return $ IR.DisplayInfoGeneric "Intro" [Unlabeled (Render.text "No introduction forms found.") Nothing Nothing] 285 | Info_Intro_ConstructorUnknown ss -> do 286 | let doc = 287 | sep 288 | [ "Don't know which constructor to introduce of", 289 | let mkOr [] = [] 290 | mkOr [x, y] = [text x <+> "or" <+> text y] 291 | mkOr (x : xs) = text x : mkOr xs 292 | in nest 2 $ fsep $ punctuate comma (mkOr ss) 293 | ] 294 | return $ IR.DisplayInfoGeneric "Intro" [Unlabeled (Render.text $ show doc) Nothing Nothing] 295 | Info_Version -> 296 | return $ IR.DisplayInfoGeneric "Agda Version" [Unlabeled (Render.text $ "Agda version " ++ versionWithCommitInfo) Nothing Nothing] 297 | Info_GoalSpecific ii kind -> lispifyGoalSpecificDisplayInfo ii kind 298 | 299 | lispifyGoalSpecificDisplayInfo :: InteractionId -> GoalDisplayInfo -> TCM IR.DisplayInfo 300 | lispifyGoalSpecificDisplayInfo ii kind = localTCState $ 301 | withInteractionId ii $ 302 | case kind of 303 | Goal_HelperFunction helperType -> do 304 | doc <- inTopContext $ prettyATop helperType 305 | return $ IR.DisplayInfoGeneric "Helper function" [Unlabeled (Render.text $ show doc ++ "\n") Nothing Nothing] 306 | Goal_NormalForm cmode expr -> do 307 | doc <- showComputed cmode expr 308 | return $ IR.DisplayInfoGeneric "Normal Form" [Unlabeled (Render.text $ show doc) Nothing Nothing] 309 | Goal_GoalType norm aux resCtxs boundaries constraints -> do 310 | goalSect <- do 311 | (rendered, raw) <- prettyTypeOfMeta norm ii 312 | return [Labeled rendered (Just raw) Nothing "Goal" "special"] 313 | 314 | auxSect <- case aux of 315 | GoalOnly -> return [] 316 | #if MIN_VERSION_Agda(2,6,4) 317 | GoalAndHave expr bndry -> do 318 | -- TODO: render bndry 319 | #else 320 | GoalAndHave expr -> do 321 | #endif 322 | rendered <- renderATop expr 323 | raw <- show <$> prettyATop expr 324 | return [Labeled rendered (Just raw) Nothing "Have" "special"] 325 | GoalAndElaboration term -> do 326 | let rendered = render term 327 | raw <- show <$> TCP.prettyTCM term 328 | return [Labeled rendered (Just raw) Nothing "Elaborates to" "special"] 329 | let boundarySect = 330 | if null boundaries 331 | then [] 332 | else 333 | Header "Boundary" 334 | : fmap (\boundary -> Unlabeled (render boundary) (Just $ show $ pretty boundary) Nothing) boundaries 335 | contextSect <- reverse . concat <$> mapM (renderResponseContext ii) resCtxs 336 | let constraintSect = 337 | if null constraints 338 | then [] 339 | else 340 | Header "Constraints" 341 | : fmap (\constraint -> Unlabeled (render constraint) (Just $ show $ pretty constraint) Nothing) constraints 342 | 343 | return $ 344 | IR.DisplayInfoGeneric "Goal type etc" $ 345 | goalSect ++ auxSect ++ boundarySect ++ contextSect ++ constraintSect 346 | Goal_CurrentGoal norm -> do 347 | (rendered, raw) <- prettyTypeOfMeta norm ii 348 | return $ IR.DisplayInfoCurrentGoal (Unlabeled rendered (Just raw) Nothing) 349 | Goal_InferredType expr -> do 350 | rendered <- renderATop expr 351 | raw <- show <$> prettyATop expr 352 | return $ IR.DisplayInfoInferredType (Unlabeled rendered (Just raw) Nothing) 353 | 354 | -- -- | Format responses of DisplayInfo 355 | -- formatPrim :: Bool -> [Block] -> String -> TCM IR.DisplayInfo 356 | -- formatPrim _copy items header = return $ IR.DisplayInfoGeneric header items 357 | 358 | -- -- | Format responses of DisplayInfo ("agda2-info-action") 359 | -- format :: [Block] -> String -> TCM IR.DisplayInfo 360 | -- format = formatPrim False 361 | 362 | -- -- | Format responses of DisplayInfo ("agda2-info-action-copy") 363 | -- formatAndCopy :: [Block] -> String -> TCM IR.DisplayInfo 364 | -- formatAndCopy = formatPrim True 365 | 366 | -------------------------------------------------------------------------------- 367 | 368 | -- | Pretty-prints the context of the given meta-variable. 369 | prettyResponseContexts :: 370 | -- | Context of this meta-variable. 371 | InteractionId -> 372 | -- | Print the elements in reverse order? 373 | Bool -> 374 | [ResponseContextEntry] -> 375 | TCM Doc 376 | prettyResponseContexts ii rev ctxs = do 377 | rows <- mapM (prettyResponseContext ii) ctxs 378 | return $ align 10 $ concat $ applyWhen rev reverse rows 379 | 380 | -- | Pretty-prints the context of the given meta-variable. 381 | prettyResponseContext :: 382 | -- | Context of this meta-variable. 383 | InteractionId -> 384 | ResponseContextEntry -> 385 | TCM [(String, Doc)] 386 | prettyResponseContext ii (ResponseContextEntry n x (Arg ai expr) letv nis) = withInteractionId ii $ do 387 | #if MIN_VERSION_Agda(2,6,4) 388 | modality <- currentModality 389 | #else 390 | modality <- asksTC getModality 391 | #endif 392 | do 393 | let prettyCtxName :: String 394 | prettyCtxName 395 | | n == x = prettyShow x 396 | | isInScope n == InScope = prettyShow n ++ " = " ++ prettyShow x 397 | | otherwise = prettyShow x 398 | 399 | -- Some attributes are useful to report whenever they are not 400 | -- in the default state. 401 | attribute :: String 402 | attribute = c ++ if null c then "" else " " 403 | where 404 | c = prettyShow (getCohesion ai) 405 | 406 | extras :: [Doc] 407 | extras = 408 | concat 409 | [ ["not in scope" | isInScope nis == C.NotInScope], 410 | -- Print erased if hypothesis is erased by goal is non-erased. 411 | ["erased" | not $ getQuantity ai `moreQuantity` getQuantity modality], 412 | -- Print irrelevant if hypothesis is strictly less relevant than goal. 413 | ["irrelevant" | not $ getRelevance ai `moreRelevant` getRelevance modality], 414 | -- Print instance if variable is considered by instance search 415 | ["instance" | isInstance ai] 416 | ] 417 | ty <- prettyATop expr 418 | 419 | letv' <- case letv of 420 | Nothing -> return [] 421 | Just val -> do 422 | val' <- prettyATop val 423 | return [(prettyShow x, "=" <+> val')] 424 | 425 | return $ 426 | (attribute ++ prettyCtxName, ":" <+> ty <+> parenSep extras) : letv' 427 | where 428 | parenSep :: [Doc] -> Doc 429 | parenSep docs 430 | | null docs = empty 431 | | otherwise = (" " <+>) $ parens $ fsep $ punctuate comma docs 432 | 433 | -- | Render the context of the given meta-variable. 434 | renderResponseContext :: 435 | -- | Context of this meta-variable. 436 | InteractionId -> 437 | ResponseContextEntry -> 438 | TCM [Block] 439 | renderResponseContext ii (ResponseContextEntry n x (Arg ai expr) letv nis) = withInteractionId ii $ do 440 | #if MIN_VERSION_Agda(2,6,4) 441 | modality <- currentModality 442 | #else 443 | modality <- asksTC getModality 444 | #endif 445 | do 446 | let rawCtxName :: String 447 | rawCtxName 448 | | n == x = prettyShow x 449 | | isInScope n == InScope = prettyShow n ++ " = " ++ prettyShow x 450 | | otherwise = prettyShow x 451 | 452 | renderedCtxName :: Inlines 453 | renderedCtxName 454 | | n == x = render x 455 | | isInScope n == InScope = render n Render.<+> "=" Render.<+> render x 456 | | otherwise = render x 457 | 458 | -- Some attributes are useful to report whenever they are not 459 | -- in the default state. 460 | rawAttribute :: String 461 | rawAttribute = c ++ if null c then "" else " " 462 | where 463 | c = prettyShow (getCohesion ai) 464 | 465 | renderedAttribute :: Inlines 466 | renderedAttribute = c <> if null (show c) then "" else " " 467 | where 468 | c = render (getCohesion ai) 469 | 470 | extras :: (IsString a) => [a] 471 | extras = 472 | concat 473 | [ ["not in scope" | isInScope nis == C.NotInScope], 474 | -- Print erased if hypothesis is erased by goal is non-erased. 475 | ["erased" | not $ getQuantity ai `moreQuantity` getQuantity modality], 476 | -- Print irrelevant if hypothesis is strictly less relevant than goal. 477 | ["irrelevant" | not $ getRelevance ai `moreRelevant` getRelevance modality], 478 | -- Print instance if variable is considered by instance search 479 | ["instance" | isInstance ai] 480 | ] 481 | 482 | extras2 :: [Inlines] 483 | extras2 = 484 | concat 485 | [ ["not in scope" | isInScope nis == C.NotInScope], 486 | -- Print erased if hypothesis is erased by goal is non-erased. 487 | ["erased" | not $ getQuantity ai `moreQuantity` getQuantity modality], 488 | -- Print irrelevant if hypothesis is strictly less relevant than goal. 489 | ["irrelevant" | not $ getRelevance ai `moreRelevant` getRelevance modality], 490 | -- Print instance if variable is considered by instance search 491 | ["instance" | isInstance ai] 492 | ] 493 | 494 | -- raw 495 | rawExpr <- prettyATop expr 496 | let rawType = show $ align 10 [(rawAttribute ++ rawCtxName, ":" <+> rawExpr <+> parenSep extras)] 497 | -- rendered 498 | renderedExpr <- renderATop expr 499 | let renderedType = (renderedCtxName <> renderedAttribute) Render.<+> ":" Render.<+> renderedExpr Render.<+> parenSep2 extras2 500 | -- (Render.fsep $ Render.punctuate "," extras) 501 | 502 | -- result 503 | let typeItem = Unlabeled renderedType (Just rawType) Nothing 504 | 505 | valueItem <- case letv of 506 | Nothing -> return [] 507 | Just val -> do 508 | valText <- renderATop val 509 | valString <- prettyATop val 510 | let renderedValue = Render.render x Render.<+> "=" Render.<+> valText 511 | let rawValue = show $ align 10 [(prettyShow x, "=" <+> valString)] 512 | return 513 | [ Unlabeled renderedValue (Just rawValue) Nothing 514 | ] 515 | 516 | return $ typeItem : valueItem 517 | where 518 | parenSep :: [Doc] -> Doc 519 | parenSep docs 520 | | null docs = empty 521 | | otherwise = (" " <+>) $ parens $ fsep $ punctuate comma docs 522 | 523 | parenSep2 :: [Inlines] -> Inlines 524 | parenSep2 docs 525 | | null docs = mempty 526 | | otherwise = (" " Render.<+>) $ Render.parens $ Render.fsep $ Render.punctuate "," docs 527 | 528 | -- | Pretty-prints the type of the meta-variable. 529 | prettyTypeOfMeta :: Rewrite -> InteractionId -> TCM (Inlines, String) 530 | prettyTypeOfMeta norm ii = do 531 | form <- B.typeOfMeta norm ii 532 | case form of 533 | OfType _ e -> do 534 | rendered <- renderATop e 535 | raw <- show <$> prettyATop e 536 | return (rendered, raw) 537 | _ -> do 538 | rendered <- renderATop form 539 | raw <- show <$> prettyATop form 540 | return (rendered, raw) 541 | 542 | -- | Prefix prettified CPUTime with "Time:" 543 | prettyTimed :: CPUTime -> Doc 544 | prettyTimed time = "Time:" <+> pretty time 545 | -------------------------------------------------------------------------------- /src/Agda/IR.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveGeneric #-} 2 | {-# LANGUAGE FunctionalDependencies #-} 3 | 4 | -- | Intermediate Representation for Agda's types 5 | module Agda.IR where 6 | 7 | import qualified Agda.Interaction.Response as Agda 8 | import Agda.TypeChecking.Monad (TCM) 9 | import Data.Aeson 10 | import GHC.Generics (Generic) 11 | import Render 12 | 13 | -------------------------------------------------------------------------------- 14 | 15 | -- | Typeclass for converting Agda values into IR 16 | class FromAgda a b | a -> b where 17 | fromAgda :: a -> b 18 | 19 | class FromAgdaTCM a b | a -> b where 20 | fromAgdaTCM :: a -> TCM b 21 | 22 | -------------------------------------------------------------------------------- 23 | 24 | -- | IR for IOCTM 25 | data Response 26 | = -- non-last responses 27 | ResponseHighlightingInfoDirect HighlightingInfos 28 | | ResponseHighlightingInfoIndirect FilePath 29 | | ResponseDisplayInfo DisplayInfo 30 | | ResponseStatus Bool Bool 31 | | ResponseClearHighlightingTokenBased 32 | | ResponseClearHighlightingNotOnlyTokenBased 33 | | ResponseRunningInfo Int String 34 | | ResponseClearRunningInfo 35 | | ResponseDoneAborting 36 | | ResponseDoneExiting 37 | | ResponseGiveAction Int GiveResult 38 | | -- priority: 1 39 | ResponseInteractionPoints [Int] 40 | | -- priority: 2 41 | ResponseMakeCaseFunction [String] 42 | | ResponseMakeCaseExtendedLambda [String] 43 | | ResponseSolveAll [(Int, String)] 44 | | ResponseMimer Int (Maybe String) 45 | | -- priority: 3 46 | ResponseJumpToError FilePath Int 47 | | ResponseEnd 48 | deriving (Generic) 49 | 50 | instance ToJSON Response 51 | 52 | -------------------------------------------------------------------------------- 53 | 54 | -- | IR for DisplayInfo 55 | data DisplayInfo 56 | = DisplayInfoGeneric String [Block] 57 | | DisplayInfoAllGoalsWarnings String [Block] [Block] [String] [String] 58 | | DisplayInfoCurrentGoal Block 59 | | DisplayInfoInferredType Block 60 | | DisplayInfoCompilationOk [String] [String] 61 | | DisplayInfoAuto String 62 | | DisplayInfoError String 63 | | DisplayInfoTime String 64 | | DisplayInfoNormalForm String 65 | deriving (Generic) 66 | 67 | instance ToJSON DisplayInfo 68 | 69 | -------------------------------------------------------------------------------- 70 | 71 | -- | GiveResult 72 | data GiveResult 73 | = GiveString String 74 | | GiveParen 75 | | GiveNoParen 76 | deriving (Generic) 77 | 78 | instance FromAgda Agda.GiveResult GiveResult where 79 | fromAgda (Agda.Give_String s) = GiveString s 80 | fromAgda Agda.Give_Paren = GiveParen 81 | fromAgda Agda.Give_NoParen = GiveNoParen 82 | 83 | instance ToJSON GiveResult 84 | 85 | -------------------------------------------------------------------------------- 86 | 87 | -- | IR for HighlightingInfo 88 | data HighlightingInfo 89 | = HighlightingInfo 90 | Int -- starting offset 91 | Int -- ending offset 92 | [String] -- list of names of aspects 93 | Bool -- is token based? 94 | String -- note 95 | (Maybe (FilePath, Int)) -- the defining module of the token and its position in that module 96 | deriving (Generic, Show) 97 | 98 | instance ToJSON HighlightingInfo 99 | 100 | data HighlightingInfos = HighlightingInfos Bool [HighlightingInfo] 101 | deriving (Generic, Show) 102 | 103 | instance ToJSON HighlightingInfos 104 | -------------------------------------------------------------------------------- /src/Agda/Parser.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | 3 | module Agda.Parser where 4 | 5 | -------------------------------------------------------------------------------- 6 | 7 | import Agda.Syntax.Parser (parseFile, runPMIO, tokensParser) 8 | import Agda.Syntax.Parser.Tokens (Token) 9 | import Agda.Syntax.Position (Position' (posPos), PositionWithoutFile, Range, RangeFile (RangeFile), getRange, rEnd', rStart') 10 | import Agda.Utils.FileName (mkAbsolute) 11 | import Control.Monad.State 12 | import Data.List (find) 13 | import Data.Maybe (fromMaybe) 14 | import Data.Text (Text, unpack) 15 | import qualified Data.Text as Text 16 | import qualified Language.LSP.Protocol.Types as LSP 17 | import Language.LSP.Server (LspM) 18 | import Monad (ServerM) 19 | import Options (Config) 20 | 21 | -------------------------------------------------------------------------------- 22 | 23 | tokenAt :: LSP.Uri -> Text -> PositionWithoutFile -> ServerM (LspM Config) (Maybe (Token, Text)) 24 | tokenAt uri source position = case LSP.uriToFilePath uri of 25 | Nothing -> return Nothing 26 | Just filepath -> do 27 | let file = RangeFile (mkAbsolute filepath) Nothing 28 | (result, _warnings) <- liftIO $ 29 | runPMIO $ do 30 | -- parse the file and get all tokens 31 | (r, _fileType) <- parseFile tokensParser file (unpack source) 32 | let tokens = fst r 33 | -- find the token at the position 34 | return $ find (pointedBy position) tokens 35 | case result of 36 | Left _err -> return Nothing 37 | Right Nothing -> return Nothing 38 | Right (Just token) -> do 39 | -- get the range of the token 40 | case tokenOffsets token of 41 | Nothing -> return Nothing 42 | Just (start, end) -> do 43 | -- get the text from the range of the token 44 | let text = Text.drop (start - 1) (Text.take (end - 1) source) 45 | return $ Just (token, text) 46 | where 47 | startAndEnd :: Range -> Maybe (PositionWithoutFile, PositionWithoutFile) 48 | startAndEnd range = do 49 | start <- rStart' range 50 | end <- rEnd' range 51 | return (start, end) 52 | 53 | pointedBy :: PositionWithoutFile -> Token -> Bool 54 | pointedBy pos token = fromMaybe False $ do 55 | (start, end) <- startAndEnd (getRange token) 56 | return $ start <= pos && pos < end 57 | 58 | tokenOffsets :: Token -> Maybe (Int, Int) 59 | tokenOffsets token = do 60 | (start, end) <- startAndEnd (getRange token) 61 | return (fromIntegral (posPos start), fromIntegral (posPos end)) 62 | -------------------------------------------------------------------------------- /src/Agda/Position.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | 3 | module Agda.Position 4 | ( ToOffset (..), 5 | makeToOffset, 6 | toOffset, 7 | FromOffset (..), 8 | makeFromOffset, 9 | fromOffset, 10 | toAgdaPositionWithoutFile, 11 | toAgdaRange, 12 | prettyPositionWithoutFile, 13 | -- , toLSPRange 14 | -- , toLSPPosition 15 | ) 16 | where 17 | 18 | import Agda.Syntax.Position 19 | import Agda.Utils.FileName (AbsolutePath (AbsolutePath)) 20 | import Data.IntMap (IntMap) 21 | import qualified Data.IntMap as IntMap 22 | import qualified Data.Sequence as Seq 23 | import qualified Data.Strict.Maybe as Strict 24 | import Data.Text (Text) 25 | import qualified Data.Text as Text 26 | import qualified Language.LSP.Protocol.Types as LSP 27 | 28 | -- Note: LSP srclocs are 0-base 29 | -- Agda srclocs are 1-base 30 | 31 | -------------------------------------------------------------------------------- 32 | 33 | -- | LSP source locations => Agda source locations 34 | 35 | -- | LSP Range -> Agda Range 36 | toAgdaRange :: ToOffset -> Text -> LSP.Range -> Range 37 | toAgdaRange table path (LSP.Range start end) = 38 | Range 39 | (Strict.Just $ mkRangeFile $ AbsolutePath path) 40 | (Seq.singleton interval) 41 | where 42 | interval :: IntervalWithoutFile 43 | interval = 44 | Interval 45 | (toAgdaPositionWithoutFile table start) 46 | (toAgdaPositionWithoutFile table end) 47 | mkRangeFile path = RangeFile path Nothing 48 | 49 | -- | LSP Position -> Agda PositionWithoutFile 50 | toAgdaPositionWithoutFile :: ToOffset -> LSP.Position -> PositionWithoutFile 51 | toAgdaPositionWithoutFile table (LSP.Position line col) = 52 | Pn 53 | () 54 | (fromIntegral (toOffset table (fromIntegral line, fromIntegral col)) + 1) 55 | (fromIntegral line + 1) 56 | (fromIntegral col + 1) 57 | 58 | prettyPositionWithoutFile :: PositionWithoutFile -> String 59 | prettyPositionWithoutFile pos@(Pn () offset _line _col) = 60 | "[" <> show pos <> "-" <> show offset <> "]" 61 | 62 | -------------------------------------------------------------------------------- 63 | 64 | -- | Positon => Offset convertion 65 | 66 | -- Keeps record of offsets of every line break ("\n", "\r" and "\r\n") 67 | -- 68 | -- Example text corresponding entry of IntMap 69 | -- >abc\n (1, 4) 70 | -- >def123\r\n (2, 11) 71 | -- >ghi\r (3, 15) 72 | -- 73 | newtype ToOffset = ToOffset {unToOffset :: IntMap Int} 74 | 75 | data Accum = Accum 76 | { accumPreviousChar :: Maybe Char, 77 | accumCurrentOffset :: Int, 78 | accumCurrentLine :: Int, 79 | accumResult :: IntMap Int 80 | } 81 | 82 | -- | Return a list of offsets of linebreaks ("\n", "\r" or "\r\n") 83 | makeToOffset :: Text -> ToOffset 84 | makeToOffset = ToOffset . accumResult . Text.foldl' go initAccum 85 | where 86 | initAccum :: Accum 87 | initAccum = Accum Nothing 0 0 IntMap.empty 88 | 89 | go :: Accum -> Char -> Accum 90 | go (Accum (Just '\r') n l table) '\n' = 91 | Accum (Just '\n') (1 + n) l (IntMap.updateMax (Just . succ) table) 92 | go (Accum previous n l table) '\n' = 93 | Accum (Just '\n') (1 + n) (1 + l) (IntMap.insert (1 + l) (1 + n) table) 94 | go (Accum previous n l table) '\r' = 95 | Accum (Just '\r') (1 + n) (1 + l) (IntMap.insert (1 + l) (1 + n) table) 96 | go (Accum previous n l table) char = Accum (Just char) (1 + n) l table 97 | 98 | -- | (line, col) => offset (zero-based) 99 | toOffset :: ToOffset -> (Int, Int) -> Int 100 | toOffset (ToOffset table) (line, col) = case IntMap.lookup line table of 101 | Nothing -> col 102 | Just offset -> offset + col 103 | 104 | -------------------------------------------------------------------------------- 105 | 106 | -- | Offset => Position convertion 107 | 108 | -- An IntMap for speeding up Offset => Position convertion 109 | -- Keeps record of offsets of every line break ("\n", "\r" and "\r\n") 110 | -- 111 | -- Example text corresponding entry of IntMap 112 | -- >abc\n (4, 1) 113 | -- >def123\r\n (11, 2) 114 | -- >ghi\r (15, 3) 115 | -- 116 | newtype FromOffset = FromOffset {unFromOffset :: IntMap Int} 117 | 118 | fromOffset :: FromOffset -> Int -> (Int, Int) 119 | fromOffset (FromOffset table) offset = case IntMap.lookupLE offset table of 120 | Nothing -> (0, offset) -- no previous lines 121 | Just (offsetOfFirstChar, lineNo) -> (lineNo, offset - offsetOfFirstChar) 122 | 123 | makeFromOffset :: Text -> FromOffset 124 | makeFromOffset = 125 | FromOffset 126 | . accumResult 127 | . Text.foldl' 128 | go 129 | (Accum Nothing 0 0 IntMap.empty) 130 | where 131 | go :: Accum -> Char -> Accum 132 | -- encountered a "\r\n", update the latest entry 133 | go (Accum (Just '\r') n l table) '\n' = case IntMap.deleteFindMax table of 134 | ((offset, lineNo), table') -> 135 | Accum (Just '\n') (1 + n) l (IntMap.insert (1 + offset) lineNo table') 136 | -- encountered a line break, add a new entry 137 | go (Accum previous n l table) '\n' = 138 | Accum (Just '\n') (1 + n) (1 + l) (IntMap.insert (1 + n) (1 + l) table) 139 | go (Accum previous n l table) '\r' = 140 | Accum (Just '\r') (1 + n) (1 + l) (IntMap.insert (1 + n) (1 + l) table) 141 | go (Accum previous n l table) char = Accum (Just char) (1 + n) l table 142 | 143 | -- -------------------------------------------------------------------------------- 144 | -- -- | Agda Highlighting Range -> Agda Range 145 | 146 | -- fromAgdaHighlightingRangeToLSPRange :: Range -> LSP.Range 147 | -- fromAgdaHighlightingRangeToLSPRange range = case rangeToIntervalWithFile range of 148 | -- Nothing -> LSP.Range (LSP.Position (-1) (-1)) (LSP.Position (-1) (-1)) 149 | -- Just (Interval start end) -> LSP.Range (toLSPPosition start) (toLSPPosition end) 150 | 151 | -- toLSPPosition :: Position -> LSP.Position 152 | -- toLSPPosition (Pn _ offset line col) = LSP.Position (fromIntegral line - 1) (fromIntegral col - 1) 153 | -------------------------------------------------------------------------------- /src/Control/Concurrent/SizedChan.hs: -------------------------------------------------------------------------------- 1 | -- | Chan with size 2 | module Control.Concurrent.SizedChan (SizedChan, newSizedChan, writeSizedChan, readSizedChan, tryReadSizedChan, peekSizedChan, tryPeekSizedChan, isEmptySizedChan) where 3 | 4 | import Control.Concurrent.Chan 5 | import Data.IORef 6 | 7 | data SizedChan a = 8 | SizedChan 9 | (Chan a) -- ^ The channel 10 | (IORef Int) -- ^ Its size 11 | (IORef (Maybe a)) -- ^ Peeked payload 12 | 13 | -- | Build and returns a new instance of 'SizedChan'. 14 | newSizedChan :: IO (SizedChan a) 15 | newSizedChan = 16 | SizedChan 17 | <$> newChan 18 | <*> newIORef 0 19 | <*> newIORef Nothing 20 | 21 | -- | Write a value to a 'SizedChan'. 22 | writeSizedChan :: SizedChan a -> a -> IO () 23 | writeSizedChan (SizedChan chan sizeIORef _) val = do 24 | writeChan chan val 25 | modifyIORef' sizeIORef succ 26 | 27 | -- | Read the next value from the 'SizedChan'. Blocks when the channel is empty. 28 | readSizedChan :: SizedChan a -> IO a 29 | readSizedChan (SizedChan chan sizeIORef peekedIORef) = do 30 | peeked <- readIORef peekedIORef 31 | case peeked of 32 | -- return and remove the peeked value 33 | Just val -> do 34 | writeIORef peekedIORef Nothing 35 | modifyIORef' sizeIORef pred 36 | return val 37 | -- else read from the channel 38 | Nothing -> do 39 | val <- readChan chan 40 | modifyIORef' sizeIORef pred 41 | return val 42 | 43 | -- | A version of `readSizedChan` which does not block. Instead it returns Nothing if no value is available. 44 | tryReadSizedChan :: SizedChan a -> IO (Maybe a) 45 | tryReadSizedChan (SizedChan chan sizeIORef peekedIORef) = do 46 | peeked <- readIORef peekedIORef 47 | case peeked of 48 | -- return and remove the peeked value 49 | Just val -> do 50 | writeIORef peekedIORef Nothing 51 | modifyIORef' sizeIORef pred 52 | return $ Just val 53 | -- check the size before reading from the channel, to prevent blocking 54 | Nothing -> do 55 | size <- readIORef sizeIORef 56 | if size == 0 57 | then return Nothing 58 | else do 59 | val <- readChan chan 60 | modifyIORef' sizeIORef pred 61 | return $ Just val 62 | 63 | -- | Peek the next value from the 'SizedChan' without removing it. Blocks when the channel is empty. 64 | peekSizedChan :: SizedChan a -> IO a 65 | peekSizedChan (SizedChan chan _ peekedIORef) = do 66 | peeked <- readIORef peekedIORef 67 | case peeked of 68 | -- return the peeked value 69 | Just val -> return val 70 | -- read from the channel instead 71 | Nothing -> do 72 | val <- readChan chan 73 | writeIORef peekedIORef (Just val) 74 | return val 75 | 76 | -- | A version of `peekSizedChan` which does not block. Instead it returns Nothing if no value is available. 77 | tryPeekSizedChan :: SizedChan a -> IO (Maybe a) 78 | tryPeekSizedChan (SizedChan chan sizeIORef peekedIORef) = do 79 | peeked <- readIORef peekedIORef 80 | case peeked of 81 | -- return the peeked value 82 | Just val -> return $ Just val 83 | -- check the size before reading from the channel, to prevent blocking 84 | Nothing -> do 85 | size <- readIORef sizeIORef 86 | if size == 0 87 | then return Nothing 88 | else do 89 | val <- readChan chan 90 | writeIORef peekedIORef (Just val) 91 | return $ Just val 92 | 93 | measureSizedChan :: SizedChan a -> IO Int 94 | measureSizedChan (SizedChan _ sizeIORef _) = readIORef sizeIORef 95 | 96 | isEmptySizedChan :: SizedChan a -> IO Bool 97 | isEmptySizedChan chan = do 98 | size <- measureSizedChan chan 99 | return $ size == 0 100 | -------------------------------------------------------------------------------- /src/Monad.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | 4 | module Monad where 5 | 6 | import Agda.IR 7 | import Agda.Interaction.Base (IOTCM) 8 | import Agda.TypeChecking.Monad (TCMT) 9 | import Control.Concurrent 10 | import Control.Monad.Reader 11 | import Data.IORef 12 | ( IORef, 13 | modifyIORef', 14 | newIORef, 15 | readIORef, 16 | writeIORef, 17 | ) 18 | import Data.Maybe (isJust) 19 | import Data.Text 20 | ( Text, 21 | pack, 22 | ) 23 | import qualified Language.LSP.Protocol.Types as LSP 24 | import Language.LSP.Server 25 | ( MonadLsp, 26 | getConfig, 27 | ) 28 | import Options 29 | import Server.CommandController (CommandController) 30 | import qualified Server.CommandController as CommandController 31 | import Server.ResponseController (ResponseController) 32 | import qualified Server.ResponseController as ResponseController 33 | 34 | -------------------------------------------------------------------------------- 35 | 36 | data Env = Env 37 | { envOptions :: Options, 38 | envDevMode :: Bool, 39 | envConfig :: Config, 40 | envLogChan :: Chan Text, 41 | envCommandController :: CommandController, 42 | envResponseChan :: Chan Response, 43 | envResponseController :: ResponseController 44 | } 45 | 46 | createInitEnv :: (MonadIO m, MonadLsp Config m) => Options -> m Env 47 | createInitEnv options = 48 | Env options (isJust (optViaTCP options)) 49 | <$> getConfig 50 | <*> liftIO newChan 51 | <*> liftIO CommandController.new 52 | <*> liftIO newChan 53 | <*> liftIO ResponseController.new 54 | 55 | -------------------------------------------------------------------------------- 56 | 57 | -- | OUR monad 58 | type ServerM m = ReaderT Env m 59 | 60 | runServerM :: Env -> ServerM m a -> m a 61 | runServerM = flip runReaderT 62 | 63 | -------------------------------------------------------------------------------- 64 | 65 | writeLog :: (Monad m, MonadIO m) => Text -> ServerM m () 66 | writeLog msg = do 67 | chan <- asks envLogChan 68 | liftIO $ writeChan chan msg 69 | 70 | writeLog' :: (Monad m, MonadIO m, Show a) => a -> ServerM m () 71 | writeLog' x = do 72 | chan <- asks envLogChan 73 | liftIO $ writeChan chan $ pack $ show x 74 | 75 | -- | Provider 76 | provideCommand :: (Monad m, MonadIO m) => IOTCM -> ServerM m () 77 | provideCommand iotcm = do 78 | controller <- asks envCommandController 79 | liftIO $ CommandController.put controller iotcm 80 | 81 | -- | Consumter 82 | consumeCommand :: (Monad m, MonadIO m) => Env -> m IOTCM 83 | consumeCommand env = liftIO $ CommandController.take (envCommandController env) 84 | 85 | waitUntilResponsesSent :: (Monad m, MonadIO m) => ServerM m () 86 | waitUntilResponsesSent = do 87 | controller <- asks envResponseController 88 | liftIO $ ResponseController.setCheckpointAndWait controller 89 | 90 | signalCommandFinish :: (Monad m, MonadIO m) => ServerM m () 91 | signalCommandFinish = do 92 | writeLog "[Command] Finished" 93 | -- send `ResponseEnd` 94 | env <- ask 95 | liftIO $ writeChan (envResponseChan env) ResponseEnd 96 | -- allow the next Command to be consumed 97 | liftIO $ CommandController.release (envCommandController env) 98 | 99 | -- | Sends a Response to the client via "envResponseChan" 100 | sendResponse :: (Monad m, MonadIO m) => Env -> Response -> TCMT m () 101 | sendResponse env response = liftIO $ writeChan (envResponseChan env) response 102 | -------------------------------------------------------------------------------- /src/Options.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | 4 | module Options 5 | ( Options (..), 6 | getOptionsFromArgv, 7 | versionString, 8 | usageMessage, 9 | Config (..), 10 | initConfig, 11 | ) 12 | where 13 | 14 | import Data.Aeson.Types hiding 15 | ( Options, 16 | defaultOptions, 17 | ) 18 | import GHC.Generics (Generic) 19 | import System.Console.GetOpt 20 | import System.Environment (getArgs) 21 | import Text.Read (readMaybe) 22 | 23 | getOptionsFromArgv :: IO Options 24 | getOptionsFromArgv = do 25 | -- extract options for Agda from ARGV 26 | (argvForALS, argvForAgda) <- extractAgdaOpts <$> getArgs 27 | -- parse options for ALS 28 | (opts, _) <- parseOpts argvForALS 29 | -- save options for Agda back 30 | return $ opts {optRawAgdaOptions = argvForAgda} 31 | 32 | usageMessage :: String 33 | usageMessage = usageInfo usage options ++ usageAboutAgdaOptions 34 | 35 | -------------------------------------------------------------------------------- 36 | 37 | -- | Command-line arguments 38 | data Options = Options 39 | { optViaTCP :: Maybe Int, 40 | optRawAgdaOptions :: [String], 41 | optHelp :: Bool, 42 | optVersion :: Bool 43 | } 44 | 45 | defaultOptions :: Options 46 | defaultOptions = 47 | Options {optViaTCP = Nothing, optRawAgdaOptions = [], optHelp = False, optVersion = False} 48 | 49 | options :: [OptDescr (Options -> Options)] 50 | options = 51 | [ Option 52 | ['h'] 53 | ["help"] 54 | (NoArg (\opts -> opts {optHelp = True})) 55 | "print this help message", 56 | Option 57 | ['p'] 58 | ["port"] 59 | ( OptArg 60 | ( \port opts -> case port of 61 | Just n -> opts {optViaTCP = readMaybe n} 62 | Nothing -> opts {optViaTCP = Just 4096} 63 | ) 64 | "PORT" 65 | ) 66 | "talk with the editor via TCP port (4096 as default)", 67 | Option 68 | ['V'] 69 | ["version"] 70 | (NoArg (\opts -> opts {optVersion = True})) 71 | "print version information and exit" 72 | ] 73 | 74 | versionNumber :: Int 75 | versionNumber = 5 76 | 77 | versionString :: String 78 | versionString = 79 | #if MIN_VERSION_Agda(2,7,0) 80 | "Agda v2.7.0.1 Language Server v" <> show versionNumber 81 | #elif MIN_VERSION_Agda(2,6,4) 82 | "Agda v2.6.4.3 Language Server v" <> show versionNumber 83 | #elif MIN_VERSION_Agda(2,6,3) 84 | "Agda v2.6.3 Language Server v" <> show versionNumber 85 | #else 86 | error "Unsupported Agda version" 87 | #endif 88 | 89 | usage :: String 90 | usage = versionString <> "\nUsage: als [Options...]\n" 91 | 92 | usageAboutAgdaOptions :: String 93 | usageAboutAgdaOptions = "\n +AGDA [Options for Agda ...] -AGDA\n To pass command line options to Agda, put them in between '+AGDA' and '-AGDA'\n For example:\n als -p=3000 +AGDA --cubical -AGDA\n If you are using agda-mode on VS Code, put them in the Settings at:\n agdaMode.connection.commandLineOptions\n" 94 | 95 | parseOpts :: [String] -> IO (Options, [String]) 96 | parseOpts argv = case getOpt Permute options argv of 97 | (o, n, []) -> return (foldl (flip id) defaultOptions o, n) 98 | (_, _, errs) -> ioError $ userError $ concat errs ++ usageInfo usage options 99 | 100 | -- | Removes RTS options from a list of options (stolen from Agda) 101 | stripRTS :: [String] -> [String] 102 | stripRTS [] = [] 103 | stripRTS ("--RTS" : argv) = argv 104 | stripRTS (arg : argv) 105 | | is "+RTS" arg = stripRTS $ drop 1 $ dropWhile (not . is "-RTS") argv 106 | | otherwise = arg : stripRTS argv 107 | where 108 | is x arg = [x] == take 1 (words arg) 109 | 110 | -- | Extract Agda options (+AGDA ... -AGDA) from a list of options 111 | extractAgdaOpts :: [String] -> ([String], [String]) 112 | extractAgdaOpts argv = 113 | let (before, argv') = break (== "+AGDA") argv 114 | (forAgda, after) = break (== "-AGDA") argv' 115 | forALS = before ++ dropWhile (== "-AGDA") after 116 | forAgda' = dropWhile (== "+AGDA") forAgda 117 | in (forALS, forAgda') 118 | 119 | -------------------------------------------------------------------------------- 120 | 121 | newtype Config = Config {configRawAgdaOptions :: [String]} 122 | deriving (Eq, Show, Generic) 123 | 124 | instance FromJSON Config where 125 | parseJSON (Object v) = Config <$> v .: "commandLineOptions" 126 | -- We do not expect a non-Object value here. 127 | -- We could use empty to fail, but typeMismatch 128 | -- gives a much more informative error message. 129 | parseJSON invalid = 130 | prependFailure "parsing Config failed, " (typeMismatch "Object" invalid) 131 | 132 | initConfig :: Config 133 | initConfig = Config [] 134 | -------------------------------------------------------------------------------- /src/Render.hs: -------------------------------------------------------------------------------- 1 | module Render 2 | ( module Render.RichText, 3 | module Render.Class, 4 | module Render.Concrete, 5 | ) 6 | where 7 | 8 | import Render.Class 9 | import Render.Concrete 10 | import Render.Interaction () 11 | import Render.Internal () 12 | import Render.Name () 13 | import Render.Position () 14 | import Render.RichText 15 | import Render.TypeChecking () 16 | import Render.Utils () 17 | -------------------------------------------------------------------------------- /src/Render/Class.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE TypeFamilies #-} 4 | 5 | module Render.Class 6 | ( Render (..), 7 | -- RenderTCM (..), 8 | renderM, 9 | renderP, 10 | renderA, 11 | renderATop, 12 | ) 13 | where 14 | 15 | import Agda.Syntax.Fixity (Precedence (TopCtx)) 16 | import qualified Agda.Syntax.Translation.AbstractToConcrete as A 17 | import qualified Agda.TypeChecking.Monad.Base as A 18 | import Agda.Utils.List1 (List1) 19 | import Agda.Utils.List2 (List2) 20 | #if MIN_VERSION_Agda(2,6,4) 21 | import Agda.Syntax.Common.Pretty (Doc) 22 | import qualified Agda.Syntax.Common.Pretty as Doc 23 | #else 24 | import Agda.Utils.Pretty (Doc) 25 | import qualified Agda.Utils.Pretty as Doc 26 | #endif 27 | 28 | import Data.Int (Int32) 29 | import GHC.Exts (IsList (toList)) 30 | import Render.RichText 31 | 32 | -------------------------------------------------------------------------------- 33 | 34 | -- | Typeclass for rendering Inlines 35 | class Render a where 36 | render :: a -> Inlines 37 | renderPrec :: Int -> a -> Inlines 38 | 39 | render = renderPrec 0 40 | renderPrec = const render 41 | 42 | -- | Rendering undersome context 43 | -- class RenderTCM a where 44 | -- renderTCM :: a -> Agda.TCM Inlines 45 | 46 | -- | Simply "pure . render" 47 | renderM :: (Applicative m, Render a) => a -> m Inlines 48 | renderM = pure . render 49 | 50 | -- | Render instances of Pretty 51 | renderP :: (Applicative m, Doc.Pretty a) => a -> m Inlines 52 | renderP = pure . text . Doc.render . Doc.pretty 53 | 54 | -- | like 'prettyA' 55 | renderA :: (Render c, A.ToConcrete a, A.ConOfAbs a ~ c) => a -> A.TCM Inlines 56 | renderA x = render <$> A.abstractToConcrete_ x 57 | 58 | -- | like 'prettyATop' 59 | renderATop :: (Render c, A.ToConcrete a, A.ConOfAbs a ~ c) => a -> A.TCM Inlines 60 | renderATop x = render <$> A.abstractToConcreteCtx TopCtx x 61 | 62 | -------------------------------------------------------------------------------- 63 | 64 | -- | Other instances of Render 65 | instance Render Int where 66 | render = text . show 67 | 68 | instance Render Int32 where 69 | render = text . show 70 | 71 | instance Render Integer where 72 | render = text . show 73 | 74 | instance Render Bool where 75 | render = text . show 76 | 77 | instance Render Doc where 78 | render = text . Doc.render 79 | 80 | instance (Render a) => Render (Maybe a) where 81 | renderPrec p Nothing = mempty 82 | renderPrec p (Just x) = renderPrec p x 83 | 84 | instance (Render a) => Render [a] where 85 | render xs = "[" <> fsep (punctuate "," (fmap render xs)) <> "]" 86 | 87 | instance (Render a) => Render (List1 a) where 88 | render = render . toList 89 | 90 | instance (Render a) => Render (List2 a) where 91 | render = render . toList 92 | -------------------------------------------------------------------------------- /src/Render/Common.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | 3 | module Render.Common where 4 | 5 | import Agda.Syntax.Common 6 | ( Cohesion (..), 7 | Erased (..), 8 | Hiding (Hidden, Instance, NotHidden), 9 | Induction (..), 10 | LensCohesion (getCohesion), 11 | LensHiding (getHiding), 12 | LensQuantity (getQuantity), 13 | LensRelevance (getRelevance), 14 | Lock (..), 15 | #if MIN_VERSION_Agda(2,6,4) 16 | LockOrigin (..), 17 | #endif 18 | MetaId (MetaId), 19 | NameId (..), 20 | Named (namedThing), 21 | #if MIN_VERSION_Agda(2,7,0) 22 | OverlapMode (..), 23 | #endif 24 | Quantity (..), 25 | QωOrigin (..), 26 | Relevance (..), 27 | RewriteEqn' (..), 28 | asQuantity, 29 | ) 30 | import Agda.Utils.Functor ((<&>)) 31 | import Agda.Utils.List1 (toList) 32 | import qualified Agda.Utils.List1 as List1 33 | import qualified Agda.Utils.Null as Agda 34 | import Render.Class 35 | import Render.RichText 36 | 37 | -------------------------------------------------------------------------------- 38 | 39 | -- | NameId 40 | instance Render NameId where 41 | render (NameId n m) = text $ show n ++ "@" ++ show m 42 | 43 | -- | MetaId 44 | instance Render MetaId where 45 | render (MetaId n m) = text $ "_" ++ show n ++ "@" ++ show m 46 | 47 | -- | Relevance 48 | instance Render Relevance where 49 | render Relevant = mempty 50 | render Irrelevant = "." 51 | render NonStrict = ".." 52 | 53 | -- | Quantity 54 | instance Render Quantity where 55 | render = \case 56 | Quantity0 o -> 57 | let s = show o 58 | in if Agda.null o 59 | then "@0" 60 | else text s 61 | Quantity1 o -> 62 | let s = show o 63 | in if Agda.null o 64 | then "@1" 65 | else text s 66 | Quantityω o -> render o 67 | 68 | instance Render QωOrigin where 69 | render = \case 70 | QωInferred -> mempty 71 | Qω {} -> "@ω" 72 | QωPlenty {} -> "@plenty" 73 | 74 | instance Render Cohesion where 75 | render Flat = "@♭" 76 | render Continuous = mempty 77 | render Squash = "@⊤" 78 | 79 | -------------------------------------------------------------------------------- 80 | 81 | #if MIN_VERSION_Agda(2,7,0) 82 | instance Render OverlapMode where 83 | render = \case 84 | Overlappable -> "OVERLAPPABLE" 85 | Overlapping -> "OVERLAPPING" 86 | Incoherent -> "INCOHERENT" 87 | Overlaps -> "OVERLAPS" 88 | FieldOverlap -> "overlap" 89 | DefaultOverlap -> mempty 90 | #endif 91 | 92 | -------------------------------------------------------------------------------- 93 | 94 | -- | From 'prettyHiding' 95 | -- @renderHiding info visible text@ puts the correct braces 96 | -- around @text@ according to info @info@ and returns 97 | -- @visible text@ if the we deal with a visible thing. 98 | renderHiding :: (LensHiding a) => a -> (Inlines -> Inlines) -> Inlines -> Inlines 99 | renderHiding a parensF = 100 | case getHiding a of 101 | Hidden -> braces' 102 | Instance {} -> dbraces 103 | NotHidden -> parensF 104 | 105 | renderRelevance :: (LensRelevance a) => a -> Inlines -> Inlines 106 | renderRelevance a d = 107 | if show d == "_" then d else render (getRelevance a) <> d 108 | 109 | renderQuantity :: (LensQuantity a) => a -> Inlines -> Inlines 110 | renderQuantity a d = 111 | if show d == "_" then d else render (getQuantity a) <+> d 112 | 113 | instance Render Lock where 114 | render = \case 115 | #if MIN_VERSION_Agda(2,6,4) 116 | IsLock LockOLock -> "@lock" 117 | IsLock LockOTick -> "@tick" 118 | #else 119 | IsLock -> "@lock" 120 | #endif 121 | IsNotLock -> mempty 122 | 123 | #if MIN_VERSION_Agda(2,7,0) 124 | renderErased :: Erased -> Inlines -> Inlines 125 | renderErased = renderQuantity . asQuantity 126 | #endif 127 | 128 | renderCohesion :: (LensCohesion a) => a -> Inlines -> Inlines 129 | renderCohesion a d = 130 | if show d == "_" then d else render (getCohesion a) <+> d 131 | 132 | -------------------------------------------------------------------------------- 133 | 134 | instance (Render p, Render e) => Render (RewriteEqn' qn nm p e) where 135 | render = \case 136 | Rewrite es -> prefixedThings (text "rewrite") (render . snd <$> toList es) 137 | Invert _ pes -> prefixedThings (text "invert") (toList pes <&> (\(p, e) -> render p <+> "<-" <+> render e) . namedThing) 138 | #if MIN_VERSION_Agda(2,7,0) 139 | LeftLet pes -> prefixedThings (text "using") [render p <+> "<-" <+> render e | (p, e) <- List1.toList pes] 140 | #endif 141 | 142 | prefixedThings :: Inlines -> [Inlines] -> Inlines 143 | prefixedThings kw = \case 144 | [] -> mempty 145 | (doc : docs) -> fsep $ (kw <+> doc) : fmap ("|" <+>) docs 146 | 147 | instance Render Induction where 148 | render Inductive = "inductive" 149 | render CoInductive = "coinductive" 150 | -------------------------------------------------------------------------------- /src/Render/Concrete.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE MultiWayIf #-} 4 | {-# LANGUAGE RankNTypes #-} 5 | 6 | module Render.Concrete where 7 | 8 | import Agda.Syntax.Common 9 | import Agda.Syntax.Concrete 10 | import Agda.Syntax.Concrete.Pretty (NamedBinding (..), Tel (..), isLabeled) 11 | import Agda.Utils.Float (toStringWithoutDotZero) 12 | import Agda.Utils.Function 13 | import Agda.Utils.Functor (dget, (<&>)) 14 | import Agda.Utils.Impossible (__IMPOSSIBLE__) 15 | import Agda.Utils.List1 as List1 (fromList, toList) 16 | import qualified Agda.Utils.List1 as List1 17 | import qualified Agda.Utils.List2 as List2 18 | import Agda.Utils.Null 19 | import Data.Maybe (isNothing, maybeToList) 20 | import qualified Data.Strict.Maybe as Strict 21 | import qualified Data.Text as T 22 | import Render.Class 23 | import Render.Common 24 | import Render.Literal () 25 | import Render.Name () 26 | import Render.RichText 27 | import Render.TypeChecking () 28 | import Prelude hiding (null) 29 | 30 | -------------------------------------------------------------------------------- 31 | 32 | #if MIN_VERSION_Agda(2,7,0) 33 | instance (Render a) => Render (TacticAttribute' a) where 34 | render (TacticAttribute t) = 35 | ifNull (render t) empty $ \d -> "@" <> parens ("tactic" <+> d) 36 | #endif 37 | 38 | instance (Render a) => Render (Ranged a) where 39 | render = render . rangedThing 40 | 41 | instance (Render a) => Render (WithHiding a) where 42 | render w = renderHiding w id $ render $ dget w 43 | 44 | instance Render Modality where 45 | render mod = 46 | hsep 47 | [ render (getRelevance mod), 48 | render (getQuantity mod), 49 | render (getCohesion mod) 50 | ] 51 | 52 | -- | OpApp 53 | instance Render (OpApp Expr) where 54 | render (Ordinary e) = render e 55 | render (SyntaxBindingLambda r bs e) = render (Lam r bs e) 56 | 57 | -- | MaybePlaceholder 58 | instance (Render a) => Render (MaybePlaceholder a) where 59 | render Placeholder {} = "_" 60 | render (NoPlaceholder _ e) = render e 61 | 62 | -------------------------------------------------------------------------------- 63 | 64 | -- | InteractionId 65 | instance Render InteractionId where 66 | render (InteractionId i) = linkHole i 67 | 68 | -------------------------------------------------------------------------------- 69 | 70 | -- | Expression 71 | instance Render Expr where 72 | render expr = case expr of 73 | Ident qname -> render qname 74 | Lit range lit -> render lit 75 | -- no hole index, use LinkRange instead 76 | QuestionMark range Nothing -> linkRange range "?" 77 | QuestionMark _range (Just n) -> linkHole n 78 | Underscore range n -> linkRange range $ maybe "_" text n 79 | -- '_range' is almost always 'NoRange' :( 80 | App _range _ _ -> 81 | case appView expr of 82 | AppView e1 args -> fsep $ render e1 : fmap render args 83 | RawApp _ es -> fsep $ fmap render (List2.toList es) 84 | OpApp _ q _ es -> fsep $ renderOpApp q es 85 | WithApp _ e es -> fsep $ render e : fmap ((text' ["delimiter"] "|" <+>) . render) es 86 | HiddenArg _ e -> braces' $ render e 87 | InstanceArg _ e -> dbraces $ render e 88 | Lam _ bs (AbsurdLam _ h) -> lambda <+> fsep (fmap render (toList bs)) <+> absurd h 89 | Lam _ bs e -> sep [lambda <+> fsep (fmap render (toList bs)) <+> arrow, render e] 90 | AbsurdLam _ h -> lambda <+> absurd h 91 | ExtendedLam range _ pes -> lambda <+> bracesAndSemicolons (fmap render (toList pes)) 92 | Fun _ e1 e2 -> 93 | sep 94 | [ renderCohesion e1 (renderQuantity e1 (render e1)) <+> arrow, 95 | render e2 96 | ] 97 | Pi tel e -> 98 | sep 99 | [ render (Tel $ smashTel (toList tel)) <+> arrow, 100 | render e 101 | ] 102 | Let _ ds me -> 103 | sep 104 | [ "let" <+> vcat (fmap render (toList ds)), 105 | maybe mempty (\e -> "in" <+> render e) me 106 | ] 107 | Paren _ e -> parens $ render e 108 | IdiomBrackets _ exprs -> 109 | case exprs of 110 | [] -> emptyIdiomBrkt 111 | [e] -> leftIdiomBrkt <+> render e <+> rightIdiomBrkt 112 | e : es -> leftIdiomBrkt <+> render e <+> fsep (fmap (("|" <+>) . render) es) <+> rightIdiomBrkt 113 | DoBlock _ ss -> "do" <+> vcat (fmap render (toList ss)) 114 | As _ x e -> render x <> "@" <> render e 115 | Dot _ e -> "." <> render e 116 | DoubleDot _ e -> ".." <> render e 117 | Absurd _ -> "()" 118 | Rec _ xs -> sep ["record", bracesAndSemicolons (fmap render xs)] 119 | RecUpdate _ e xs -> 120 | sep ["record" <+> render e, bracesAndSemicolons (fmap render xs)] 121 | Quote _ -> "quote" 122 | QuoteTerm _ -> "quoteTerm" 123 | Unquote _ -> "unquote" 124 | Tactic _ t -> "tactic" <+> render t 125 | -- Andreas, 2011-10-03 print irrelevant things as .(e) 126 | DontCare e -> "." <> parens (render e) 127 | Equal _ a b -> render a <+> "=" <+> render b 128 | Ellipsis _ -> "..." 129 | Generalized e -> render e 130 | #if MIN_VERSION_Agda(2,6,4) 131 | KnownIdent _ q -> render q 132 | KnownOpApp _ _ q _ es -> fsep $ renderOpApp q es 133 | #endif 134 | where 135 | absurd NotHidden = "()" 136 | absurd Instance {} = "{{}}" 137 | absurd Hidden = "{}" 138 | 139 | -------------------------------------------------------------------------------- 140 | 141 | instance (Render a, Render b) => Render (Either a b) where 142 | render = either render render 143 | 144 | instance (Render a) => Render (FieldAssignment' a) where 145 | render (FieldAssignment x e) = sep [render x <+> "=", render e] 146 | 147 | instance Render ModuleAssignment where 148 | render (ModuleAssignment m es i) = fsep (render m : fmap render es) <+> render i 149 | 150 | instance Render LamClause where 151 | render (LamClause lhs rhs _) = 152 | sep 153 | [ render lhs, 154 | render' rhs 155 | ] 156 | where 157 | render' (RHS e) = arrow <+> render e 158 | render' AbsurdRHS = mempty 159 | 160 | instance Render BoundName where 161 | render BName {boundName = x} = render x 162 | 163 | instance (Render a) => Render (Binder' a) where 164 | render (Binder mpat n) = 165 | let d = render n 166 | in case mpat of 167 | Nothing -> d 168 | Just pat -> d <+> "@" <+> parens (render pat) 169 | 170 | -------------------------------------------------------------------------------- 171 | 172 | -- | NamedBinding 173 | instance Render NamedBinding where 174 | #if MIN_VERSION_Agda(2,7,0) 175 | render 176 | ( NamedBinding 177 | withH 178 | x@( Arg 179 | (ArgInfo h (Modality r q c) _o _fv (Annotation lock)) 180 | (Named _mn xb@(Binder _mp (BName _y _fix t _fin))) 181 | ) 182 | ) = 183 | applyWhen withH prH $ 184 | applyWhenJust (isLabeled x) (\l -> (text l <+>) . ("=" <+>)) (render xb) 185 | where 186 | -- isLabeled looks at _mn and _y 187 | -- pretty xb prints also the pattern _mp 188 | 189 | prH = 190 | (render r <>) 191 | . renderHiding h mparens 192 | . (coh <+>) 193 | . (qnt <+>) 194 | . (lck <+>) 195 | . (tac <+>) 196 | coh = render c 197 | qnt = render q 198 | tac = render t 199 | lck = render lock 200 | -- Parentheses are needed when an attribute @... is printed 201 | mparens = applyUnless (null coh && null qnt && null lck && null tac) parens 202 | 203 | #else 204 | render (NamedBinding withH x) = 205 | prH $ 206 | if 207 | | Just l <- isLabeled x -> text l <> " = " <> render xb 208 | | otherwise -> render xb 209 | where 210 | xb = namedArg x 211 | bn = binderName xb 212 | prH 213 | | withH = 214 | renderRelevance x 215 | . renderHiding x mparens' 216 | . renderCohesion x 217 | . renderQuantity x 218 | . renderTactic bn 219 | | otherwise = id 220 | -- Parentheses are needed when an attribute @... is present 221 | mparens' 222 | | noUserQuantity x, Nothing <- bnameTactic bn = id 223 | | otherwise = parens 224 | #endif 225 | 226 | renderTactic :: BoundName -> Inlines -> Inlines 227 | renderTactic = renderTactic' . bnameTactic 228 | 229 | renderTactic' :: TacticAttribute -> Inlines -> Inlines 230 | #if MIN_VERSION_Agda(2,7,0) 231 | renderTactic' t = (render t <+>) 232 | #else 233 | renderTactic' Nothing d = d 234 | renderTactic' (Just t) d = "@" <> (parens ("tactic " <> render t) <+> d) 235 | #endif 236 | 237 | -------------------------------------------------------------------------------- 238 | 239 | -- | LamBinding 240 | instance Render LamBinding where 241 | render (DomainFree x) = render (NamedBinding True x) 242 | render (DomainFull b) = render b 243 | 244 | -- | TypedBinding 245 | instance Render TypedBinding where 246 | render (TLet _ ds) = parens $ "let" <+> vcat (fmap render (toList ds)) 247 | render (TBind _ xs (Underscore _ Nothing)) = 248 | fsep (fmap (render . NamedBinding True) (toList xs)) 249 | render (TBind _ binders e) = 250 | fsep 251 | [ renderRelevance y $ 252 | renderHiding y parens $ 253 | renderCohesion y $ 254 | renderQuantity y $ 255 | renderTactic (binderName $ namedArg y) $ 256 | sep 257 | [ fsep (fmap (render . NamedBinding False) ys), 258 | ":" <+> render e 259 | ] 260 | | ys@(y : _) <- groupBinds (toList binders) 261 | ] 262 | where 263 | groupBinds [] = [] 264 | groupBinds (x : xs) 265 | | Just {} <- isLabeled x = [x] : groupBinds xs 266 | | otherwise = (x : ys) : groupBinds zs 267 | where 268 | (ys, zs) = span (same x) xs 269 | same a b = getArgInfo a == getArgInfo b && isNothing (isLabeled b) 270 | 271 | instance Render Tel where 272 | render (Tel tel) 273 | | any isMeta tel = forallQ <+> fsep (fmap render tel) 274 | | otherwise = fsep (fmap render tel) 275 | where 276 | isMeta (TBind _ _ (Underscore _ Nothing)) = True 277 | isMeta _ = False 278 | 279 | smashTel :: Telescope -> Telescope 280 | smashTel 281 | ( TBind r xs e 282 | : TBind _ ys e' 283 | : tel 284 | ) 285 | | show e == show e' = smashTel (TBind r (fromList (toList xs ++ toList ys)) e : tel) 286 | smashTel (b : tel) = b : smashTel tel 287 | smashTel [] = [] 288 | 289 | instance Render RHS where 290 | render (RHS e) = "=" <+> render e 291 | render AbsurdRHS = mempty 292 | 293 | instance Render WhereClause where 294 | render NoWhere = mempty 295 | #if MIN_VERSION_Agda(2,6,4) 296 | render (AnyWhere _range [Module _ _ x [] ds]) 297 | #else 298 | render (AnyWhere _range [Module _ x [] ds]) 299 | #endif 300 | | isNoName (unqualify x) = 301 | vcat ["where", vcat $ fmap render ds] 302 | render (AnyWhere _range ds) = vcat ["where", vcat $ fmap render ds] 303 | #if MIN_VERSION_Agda(2,7,0) 304 | render (SomeWhere _ erased m a ds) = 305 | vcat 306 | [ hsep $ 307 | privateWhenUserWritten 308 | a 309 | ["module", renderErased erased (render m), "where"], 310 | vcat $ map render ds 311 | ] 312 | where 313 | privateWhenUserWritten = \case 314 | PrivateAccess _ UserWritten -> ("private" :) 315 | _ -> id 316 | 317 | #else 318 | #if MIN_VERSION_Agda(2,6,4) 319 | render (SomeWhere _range _er m a ds) = 320 | #else 321 | render (SomeWhere _range m a ds) = 322 | #endif 323 | vcat 324 | [ hsep $ 325 | applyWhen 326 | (a == PrivateAccess UserWritten) 327 | ("private" :) 328 | ["module", render m, "where"], 329 | vcat $ fmap render ds 330 | ] 331 | #endif 332 | 333 | instance Render LHS where 334 | render (LHS p eqs es) = 335 | sep 336 | [ render p, 337 | if null eqs then mempty else fsep $ fmap render eqs, 338 | prefixedThings "with" (fmap renderWithd es) 339 | ] 340 | where 341 | renderWithd :: WithExpr -> Inlines 342 | renderWithd (Named nm wh) = 343 | let e = render wh 344 | in case nm of 345 | Nothing -> e 346 | Just n -> render n <+> ":" <+> e 347 | 348 | instance Render LHSCore where 349 | render (LHSHead f ps) = sep $ render f : fmap (parens . render) ps 350 | render (LHSProj d ps lhscore ps') = 351 | sep $ 352 | render d 353 | : fmap (parens . render) ps 354 | ++ parens (render lhscore) 355 | : fmap (parens . render) ps' 356 | render (LHSWith h wps ps) = 357 | if null ps 358 | then doc 359 | else sep $ parens doc : fmap (parens . render) ps 360 | where 361 | doc = sep $ render h : fmap (("|" <+>) . render) wps 362 | render (LHSEllipsis r p) = "..." 363 | 364 | instance Render ModuleApplication where 365 | render (SectionApp _ bs e) = fsep (fmap render bs) <+> "=" <+> render e 366 | render (RecordModuleInstance _ rec) = "=" <+> render rec <+> "{{...}}" 367 | 368 | instance Render DoStmt where 369 | render (DoBind _ p e cs) = 370 | fsep [render p <+> "←", render e, prCs cs] 371 | where 372 | prCs [] = mempty 373 | prCs cs' = fsep ["where", vcat (fmap render cs')] 374 | render (DoThen e) = render e 375 | render (DoLet _ ds) = "let" <+> vcat (render <$> toList ds) 376 | 377 | instance Render Declaration where 378 | render d = 379 | case d of 380 | TypeSig i tac x e -> 381 | sep 382 | [ renderTactic' tac $ renderRelevance i $ renderCohesion i $ renderQuantity i $ render x <+> ":", 383 | render e 384 | ] 385 | FieldSig inst tac x (Arg i e) -> 386 | mkInst inst $ 387 | mkOverlap i $ 388 | renderRelevance i $ 389 | renderHiding i id $ 390 | renderCohesion i $ 391 | renderQuantity i $ 392 | render $ 393 | TypeSig (setRelevance Relevant i) tac x e 394 | where 395 | mkInst (InstanceDef _) f = sep ["instance", f] 396 | mkInst NotInstanceDef f = f 397 | #if MIN_VERSION_Agda(2,7,0) 398 | mkOverlap i d 399 | | isYesOverlap i = "overlap" <+> d 400 | #else 401 | mkOverlap i d | isOverlappable i = "overlap" <+> d 402 | #endif 403 | | otherwise = d 404 | Field _ fs -> 405 | sep 406 | [ "field", 407 | vcat (fmap render fs) 408 | ] 409 | FunClause lhs rhs wh _ -> 410 | sep 411 | [ render lhs, 412 | render rhs, 413 | render wh 414 | ] 415 | #if MIN_VERSION_Agda(2,6,4) 416 | DataSig _ _er x tel e -> 417 | #else 418 | DataSig _ x tel e -> 419 | #endif 420 | fsep 421 | [ hsep 422 | [ "data", 423 | render x, 424 | fcat (fmap render tel) 425 | ], 426 | hsep 427 | [ ":", 428 | render e 429 | ] 430 | ] 431 | #if MIN_VERSION_Agda(2,6,4) 432 | Data _ _er x tel e cs -> 433 | #else 434 | Data _ x tel e cs -> 435 | #endif 436 | fsep 437 | [ hsep 438 | [ "data", 439 | render x, 440 | fcat (fmap render tel) 441 | ], 442 | hsep 443 | [ ":", 444 | render e, 445 | "where" 446 | ], 447 | vcat $ fmap render cs 448 | ] 449 | DataDef _ x tel cs -> 450 | sep 451 | [ hsep 452 | [ "data", 453 | render x, 454 | fcat (fmap render tel) 455 | ], 456 | "where", 457 | vcat $ fmap render cs 458 | ] 459 | #if MIN_VERSION_Agda(2,6,4) 460 | RecordSig _ _er x tel e -> 461 | #else 462 | RecordSig _ x tel e -> 463 | #endif 464 | sep 465 | [ hsep 466 | [ "record", 467 | render x, 468 | fcat (fmap render tel) 469 | ], 470 | hsep 471 | [ ":", 472 | render e 473 | ] 474 | ] 475 | #if MIN_VERSION_Agda(2,7,0) 476 | Record _ erased x dir tel e cs -> pRecord erased x dir tel (Just e) cs 477 | #else 478 | #if MIN_VERSION_Agda(2,6,4) 479 | Record _ _er x dir tel e cs -> pRecord x dir tel (Just e) cs 480 | #else 481 | Record _ x dir tel e cs -> pRecord x dir tel (Just e) cs 482 | #endif 483 | #endif 484 | #if MIN_VERSION_Agda(2,7,0) 485 | RecordDef _ x dir tel cs -> pRecord defaultErased x dir tel Nothing cs 486 | #else 487 | RecordDef _ x dir tel cs -> pRecord x dir tel Nothing cs 488 | #endif 489 | #if !MIN_VERSION_Agda(2,7,0) 490 | RecordDirective r -> pRecordDirective r 491 | #endif 492 | Infix f xs -> render f <+> fsep (punctuate "," $ fmap render (toList xs)) 493 | Syntax n _ -> "syntax" <+> render n <+> "..." 494 | PatternSyn _ n as p -> 495 | "pattern" 496 | <+> render n 497 | <+> fsep (fmap render as) 498 | <+> "=" 499 | <+> render p 500 | Mutual _ ds -> namedBlock "mutual" ds 501 | InterleavedMutual _ ds -> namedBlock "interleaved mutual" ds 502 | LoneConstructor _ ds -> namedBlock "constructor" ds 503 | Abstract _ ds -> namedBlock "abstract" ds 504 | Private _ _ ds -> namedBlock "private" ds 505 | InstanceB _ ds -> namedBlock "instance" ds 506 | Macro _ ds -> namedBlock "macro" ds 507 | Postulate _ ds -> namedBlock "postulate" ds 508 | Primitive _ ds -> namedBlock "primitive" ds 509 | Generalize _ ds -> namedBlock "variable" ds 510 | #if MIN_VERSION_Agda(2,6,4) 511 | Module _ _er x tel ds -> 512 | #else 513 | Module _ x tel ds -> 514 | #endif 515 | fsep 516 | [ hsep 517 | [ "module", 518 | render x, 519 | fcat (fmap render tel), 520 | "where" 521 | ], 522 | vcat $ fmap render ds 523 | ] 524 | #if MIN_VERSION_Agda(2,6,4) 525 | ModuleMacro _ _er x m open i -> case m of 526 | #else 527 | ModuleMacro _ x m open i -> case m of 528 | #endif 529 | (SectionApp _ [] e) 530 | | open == DoOpen, 531 | isNoName x -> 532 | fsep 533 | [ render open, 534 | render e, 535 | render i 536 | ] 537 | (SectionApp _ tel e) -> 538 | fsep 539 | [ render open <+> "module" <+> render x <+> fcat (fmap render tel), 540 | "=" <+> render e <+> render i 541 | ] 542 | (RecordModuleInstance _ rec) -> 543 | fsep 544 | [ render open <+> "module" <+> render x, 545 | "=" <+> render rec <+> "{{...}}" 546 | ] 547 | Open _ x i -> hsep ["open", render x, render i] 548 | Import _ x rn open i -> 549 | hsep [render open, "import", render x, as rn, render i] 550 | where 551 | as Nothing = mempty 552 | as (Just y) = "as" <+> render (asName y) 553 | UnquoteDecl _ xs t -> 554 | fsep ["unquoteDecl" <+> fsep (fmap render xs) <+> "=", render t] 555 | UnquoteDef _ xs t -> 556 | fsep ["unquoteDef" <+> fsep (fmap render xs) <+> "=", render t] 557 | Pragma pr -> sep ["{-#" <+> render pr, "#-}"] 558 | UnquoteData _ x xs e -> 559 | fsep [hsep ["unquoteData", render x, fsep (fmap render xs), "="], render e] 560 | #if MIN_VERSION_Agda(2,6,4) 561 | Opaque _ ds -> 562 | namedBlock "opaque" ds 563 | Unfolding _ xs -> 564 | fsep ("unfolding" : fmap render xs) 565 | #endif 566 | where 567 | 568 | namedBlock s ds = 569 | fsep 570 | [ text s, 571 | vcat $ fmap render ds 572 | ] 573 | 574 | pHasEta0 :: HasEta0 -> Inlines 575 | pHasEta0 = \case 576 | YesEta -> "eta-equality" 577 | NoEta () -> "no-eta-equality" 578 | 579 | instance Render RecordDirective where 580 | render = pRecordDirective 581 | 582 | pRecordDirective :: 583 | RecordDirective -> 584 | Inlines 585 | pRecordDirective = \case 586 | Induction ind -> render ind 587 | Constructor n inst -> hsep [pInst, "constructor", render n] 588 | where 589 | pInst = case inst of 590 | InstanceDef {} -> "instance" 591 | NotInstanceDef {} -> mempty 592 | Eta eta -> pHasEta0 (rangedThing eta) 593 | PatternOrCopattern {} -> "pattern" 594 | 595 | #if MIN_VERSION_Agda(2,7,0) 596 | pRecord :: 597 | Erased -> 598 | Name -> 599 | [RecordDirective] -> 600 | [LamBinding] -> 601 | Maybe Expr -> 602 | [Declaration] -> 603 | Inlines 604 | pRecord erased x directives tel me ds = 605 | vcat 606 | [ sep 607 | [ hsep 608 | [ "record", 609 | renderErased erased (render x), 610 | fsep (map render tel) 611 | ], 612 | pType me 613 | ], 614 | vcat $ 615 | concat 616 | [ map render directives, 617 | map render ds 618 | ] 619 | ] 620 | where 621 | pType (Just e) = 622 | hsep 623 | [ ":", 624 | render e, 625 | "where" 626 | ] 627 | pType Nothing = 628 | "where" 629 | 630 | #else 631 | pRecord :: 632 | Name -> 633 | RecordDirectives -> 634 | [LamBinding] -> 635 | Maybe Expr -> 636 | [Declaration] -> 637 | Inlines 638 | pRecord x (RecordDirectives ind eta pat con) tel me cs = 639 | sep 640 | [ hsep 641 | [ "record", 642 | render x, 643 | fcat (fmap render tel) 644 | ], 645 | pType me, 646 | vcat $ 647 | pInd 648 | ++ pEta 649 | ++ pCon 650 | ++ fmap render cs 651 | ] 652 | where 653 | pType (Just e) = 654 | hsep 655 | [ ":", 656 | render e, 657 | "where" 658 | ] 659 | pType Nothing = 660 | "where" 661 | pInd = maybeToList $ text . show . rangedThing <$> ind 662 | pEta = 663 | maybeToList $ 664 | eta <&> \case 665 | YesEta -> "eta-equality" 666 | NoEta _ -> "no-eta-equality" 667 | pCon = maybeToList $ (("constructor" <+>) . render) . fst <$> con 668 | #endif 669 | 670 | instance Render OpenShortHand where 671 | render DoOpen = "open" 672 | render DontOpen = mempty 673 | 674 | instance Render Pragma where 675 | render (OptionsPragma _ opts) = fsep $ fmap text $ "OPTIONS" : opts 676 | render (BuiltinPragma _ b x) = hsep ["BUILTIN", text (rangedThing b), render x] 677 | render (RewritePragma _ _ xs) = 678 | hsep ["REWRITE", hsep $ fmap render xs] 679 | render (CompilePragma _ b x e) = 680 | hsep ["COMPILE", text (rangedThing b), render x, text e] 681 | render (ForeignPragma _ b s) = 682 | vcat $ text ("FOREIGN " ++ rangedThing b) : fmap text (lines s) 683 | render (StaticPragma _ i) = 684 | hsep ["STATIC", render i] 685 | render (InjectivePragma _ i) = 686 | hsep ["INJECTIVE", render i] 687 | render (InlinePragma _ True i) = 688 | hsep ["INLINE", render i] 689 | render (InlinePragma _ False i) = 690 | hsep ["NOINLINE", render i] 691 | render (ImpossiblePragma _ strs) = 692 | hsep $ "IMPOSSIBLE" : fmap text strs 693 | render (EtaPragma _ x) = 694 | hsep ["ETA", render x] 695 | render (TerminationCheckPragma _ tc) = 696 | case tc of 697 | TerminationCheck -> __IMPOSSIBLE__ 698 | NoTerminationCheck -> "NO_TERMINATION_CHECK" 699 | NonTerminating -> "NON_TERMINATING" 700 | Terminating -> "TERMINATING" 701 | TerminationMeasure _ x -> hsep ["MEASURE", render x] 702 | render (NoCoverageCheckPragma _) = "NON_COVERING" 703 | render (WarningOnUsage _ nm str) = hsep ["WARNING_ON_USAGE", render nm, text $ T.unpack str] 704 | render (WarningOnImport _ str) = hsep ["WARNING_ON_IMPORT", text $ T.unpack str] 705 | render (CatchallPragma _) = "CATCHALL" 706 | render (DisplayPragma _ lhs rhs) = "DISPLAY" <+> fsep [render lhs <+> "=", render rhs] 707 | render (NoPositivityCheckPragma _) = "NO_POSITIVITY_CHECK" 708 | render (PolarityPragma _ q occs) = 709 | hsep ("POLARITY" : render q : fmap render occs) 710 | render (NoUniverseCheckPragma _) = "NO_UNIVERSE_CHECK" 711 | render (NotProjectionLikePragma _ q) = 712 | hsep ["NOT_PROJECTION_LIKE", render q] 713 | #if MIN_VERSION_Agda(2,7,0) 714 | render (InjectiveForInferencePragma _ i) = 715 | hsep ["INJECTIVE_FOR_INFERENCE", render i] 716 | render (OverlapPragma _ x m) = hsep [render m, render x] 717 | #endif 718 | 719 | instance Render Fixity where 720 | render (Fixity _ Unrelated _) = __IMPOSSIBLE__ 721 | render (Fixity _ (Related d) ass) = s <+> text (toStringWithoutDotZero d) 722 | where 723 | s = case ass of 724 | LeftAssoc -> "infixl" 725 | RightAssoc -> "infixr" 726 | NonAssoc -> "infix" 727 | 728 | instance Render NotationPart where 729 | render = \case 730 | IdPart x -> text $ rangedThing x 731 | HolePart {} -> "_" 732 | VarPart {} -> "_" 733 | WildPart {} -> "_" 734 | 735 | instance Render Fixity' where 736 | render (Fixity' fix nota _) 737 | | nota == noNotation = render fix 738 | | otherwise = "syntax" <+> render nota 739 | 740 | -- | Arg 741 | instance (Render a) => Render (Arg a) where 742 | renderPrec p (Arg ai e) = renderHiding ai localParens $ renderPrec p' e 743 | where 744 | p' 745 | | visible ai = p 746 | | otherwise = 0 747 | localParens 748 | | getOrigin ai == Substitution = parens 749 | | otherwise = id 750 | 751 | -- | Named NamedName (Named_) 752 | instance (Render e) => Render (Named NamedName e) where 753 | renderPrec p (Named nm e) 754 | | Just s <- bareNameOf nm = mparens (p > 0) $ sep [text s <> " =", render e] 755 | | otherwise = renderPrec p e 756 | 757 | instance Render Pattern where 758 | render = \case 759 | #if MIN_VERSION_Agda(2,6,4) 760 | IdentP _ x -> render x 761 | #else 762 | IdentP x -> render x 763 | #endif 764 | AppP p1 p2 -> fsep [render p1, render p2] 765 | RawAppP _ ps -> fsep $ fmap render (List2.toList ps) 766 | OpAppP _ q _ ps -> fsep $ renderOpApp q (fmap (fmap (fmap (NoPlaceholder Strict.Nothing))) ps) 767 | HiddenP _ p -> braces' $ render p 768 | InstanceP _ p -> dbraces $ render p 769 | ParenP _ p -> parens $ render p 770 | WildP _ -> "_" 771 | AsP _ x p -> render x <> "@" <> render p 772 | DotP _ p -> "." <> render p 773 | AbsurdP _ -> "()" 774 | LitP _ l -> render l 775 | QuoteP _ -> "quote" 776 | RecP _ fs -> sep ["record", bracesAndSemicolons (fmap render fs)] 777 | EqualP _ es -> sep $ [parens (sep [render e1, "=", render e2]) | (e1, e2) <- es] 778 | EllipsisP _ mp -> "..." 779 | WithP _ p -> "|" <+> render p 780 | 781 | bracesAndSemicolons :: [Inlines] -> Inlines 782 | bracesAndSemicolons [] = "{}" 783 | bracesAndSemicolons (d : ds) = sep (["{" <+> d] ++ fmap (";" <+>) ds ++ ["}"]) 784 | 785 | renderOpApp :: 786 | forall a. 787 | (Render a) => 788 | QName -> 789 | [NamedArg (MaybePlaceholder a)] -> 790 | [Inlines] 791 | renderOpApp q args = merge [] $ prOp moduleNames concreteNames args 792 | where 793 | -- ms: the module part of the name. 794 | moduleNames = List1.init (qnameParts q) 795 | -- xs: the concrete name (alternation of @Id@ and @Hole@) 796 | concreteNames = case unqualify q of 797 | Name _ _ xs -> List1.toList xs 798 | NoName {} -> __IMPOSSIBLE__ 799 | 800 | prOp :: (Render a) => [Name] -> [NamePart] -> [NamedArg (MaybePlaceholder a)] -> [(Inlines, Maybe PositionInName)] 801 | prOp ms (Hole : xs) (e : es) = 802 | case namedArg e of 803 | Placeholder p -> (qual ms $ render e, Just p) : prOp [] xs es 804 | NoPlaceholder {} -> (render e, Nothing) : prOp ms xs es 805 | -- Module qualifier needs to go on section holes (#3072) 806 | prOp _ (Hole : _) [] = __IMPOSSIBLE__ 807 | prOp ms (Id x : xs) es = 808 | ( qual ms $ render $ simpleName x, 809 | Nothing 810 | ) 811 | : prOp [] xs es 812 | -- Qualify the name part with the module. 813 | -- We then clear @ms@ such that the following name parts will not be qualified. 814 | 815 | prOp _ [] es = fmap (\e -> (render e, Nothing)) es 816 | 817 | qual ms' doc = hcat $ punctuate "." $ fmap render ms' ++ [doc] 818 | 819 | -- Section underscores should be printed without surrounding 820 | -- whitespace. This function takes care of that. 821 | merge :: [Inlines] -> [(Inlines, Maybe PositionInName)] -> [Inlines] 822 | merge before [] = reverse before 823 | merge before ((d, Nothing) : after) = merge (d : before) after 824 | merge before ((d, Just Beginning) : after) = mergeRight before d after 825 | merge before ((d, Just End) : after) = case mergeLeft d before of 826 | (d', bs) -> merge (d' : bs) after 827 | merge before ((d, Just Middle) : after) = case mergeLeft d before of 828 | (d', bs) -> mergeRight bs d' after 829 | 830 | mergeRight before d after = 831 | reverse before 832 | ++ case merge [] after of 833 | [] -> [d] 834 | a : as -> (d <> a) : as 835 | 836 | mergeLeft d before = case before of 837 | [] -> (d, []) 838 | b : bs -> (b <> d, bs) 839 | 840 | instance (Render a, Render b) => Render (ImportDirective' a b) where 841 | render i = 842 | sep 843 | [ public (publicOpen i), 844 | render $ using i, 845 | renderHiding' $ hiding i, 846 | rename $ impRenaming i 847 | ] 848 | where 849 | public Just {} = "public" 850 | public Nothing = mempty 851 | 852 | renderHiding' [] = mempty 853 | renderHiding' xs = "hiding" <+> parens (fsep $ punctuate ";" $ fmap render xs) 854 | 855 | rename [] = mempty 856 | rename xs = 857 | hsep 858 | [ "renaming", 859 | parens $ fsep $ punctuate ";" $ fmap render xs 860 | ] 861 | 862 | instance (Render a, Render b) => Render (Using' a b) where 863 | render UseEverything = mempty 864 | render (Using xs) = 865 | "using" <+> parens (fsep $ punctuate ";" $ fmap render xs) 866 | 867 | instance (Render a, Render b) => Render (Renaming' a b) where 868 | render (Renaming from to mfx _r) = 869 | hsep 870 | [ render from, 871 | "to", 872 | maybe mempty render mfx, 873 | case to of 874 | ImportedName a -> render a 875 | ImportedModule b -> render b -- don't print "module" here 876 | ] 877 | 878 | instance (Render a, Render b) => Render (ImportedName' a b) where 879 | render (ImportedName a) = render a 880 | render (ImportedModule b) = "module" <+> render b 881 | -------------------------------------------------------------------------------- /src/Render/Interaction.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | 4 | module Render.Interaction where 5 | 6 | import Agda.Interaction.Base 7 | #if MIN_VERSION_Agda(2,7,0) 8 | import Agda.Interaction.Output (OutputConstraint, OutputForm) 9 | #endif 10 | import Agda.Syntax.Internal (Blocker (..)) 11 | import Agda.TypeChecking.Monad 12 | import qualified Data.IntMap as IntMap 13 | import qualified Data.Map as Map 14 | import qualified Data.Set as Set 15 | import Render.Class 16 | import Render.Concrete () 17 | import Render.Internal () 18 | import Render.Name () 19 | import Render.Position () 20 | import Render.RichText 21 | import Render.TypeChecking () 22 | 23 | -------------------------------------------------------------------------------- 24 | 25 | -- | OutputForm 26 | instance (Render a, Render b) => Render (OutputForm a b) where 27 | render (OutputForm r pids unblock c) = 28 | fsep 29 | [render c, prange r, parens (sep [blockedOn unblock, prPids pids])] 30 | where 31 | prPids [] = mempty 32 | prPids [pid] = parens $ "belongs to problem" <+> render pid 33 | prPids pids' = 34 | parens $ 35 | "belongs to problems" 36 | <+> fsep 37 | (punctuate "," $ fmap render pids') 38 | 39 | comma 40 | | null pids = mempty 41 | | otherwise = "," 42 | 43 | blockedOn (UnblockOnAll bs) | Set.null bs = mempty 44 | blockedOn (UnblockOnAny bs) | Set.null bs = "stuck" <> comma 45 | blockedOn u = "blocked on" <+> (render u <> comma) 46 | 47 | prange rr 48 | | null s = mempty 49 | | otherwise = text $ " [ at " ++ s ++ " ]" 50 | where 51 | s = show $ render rr 52 | 53 | -- | OutputConstraint 54 | instance (Render a, Render b) => Render (OutputConstraint a b) where 55 | render (OfType name expr) = render name <> " : " <> render expr 56 | render (JustType name) = "Type " <> render name 57 | render (JustSort name) = "Sort " <> render name 58 | render (CmpInType cmp expr name1 name2) = 59 | render name1 60 | <> " " 61 | <> render cmp 62 | <> " " 63 | <> render name2 64 | <> " : " 65 | <> render expr 66 | render (CmpElim pols expr names1 names2) = 67 | render names1 68 | <> " " 69 | <> render pols 70 | <> " " 71 | <> render names2 72 | <> " : " 73 | <> render expr 74 | render (CmpTypes cmp name1 name2) = 75 | render name1 <> " " <> render cmp <> " " <> render name2 76 | render (CmpLevels cmp name1 name2) = 77 | render name1 <> " " <> render cmp <> " " <> render name2 78 | render (CmpTeles cmp name1 name2) = 79 | render name1 <> " " <> render cmp <> " " <> render name2 80 | render (CmpSorts cmp name1 name2) = 81 | render name1 <> " " <> render cmp <> " " <> render name2 82 | render (Assign name expr) = render name <> " := " <> render expr 83 | render (TypedAssign name expr1 expr2) = 84 | render name <> " := " <> render expr1 <> " :? " <> render expr2 85 | render (PostponedCheckArgs name exprs expr1 expr2) = 86 | let exprs' = fmap (parens . render) exprs 87 | in render name 88 | <> " := " 89 | <> parens ("_ : " <> render expr1) 90 | <> " " 91 | <> fsep exprs' 92 | <> " : " 93 | <> render expr2 94 | render (IsEmptyType expr) = "Is empty: " <> render expr 95 | render (SizeLtSat expr) = "Not empty type of sizes: " <> render expr 96 | render (FindInstanceOF name expr exprs) = 97 | let exprs' = 98 | (\(q, e, t) -> render q <> "=" <> render e <> " : " <> render t) 99 | <$> exprs 100 | in fsep 101 | [ "Resolve instance argument ", 102 | render name <> " : " <> render expr, 103 | "Candidate:", 104 | vcat exprs' 105 | ] 106 | #if MIN_VERSION_Agda(2,7,0) 107 | render (ResolveInstanceOF q) = "Resolve output type of instance" render q 108 | #endif 109 | render (PTSInstance name1 name2) = 110 | "PTS instance for (" <> render name1 <> ", " <> render name2 <> ")" 111 | render (PostponedCheckFunDef name expr _err) = 112 | "Check definition of " <> render name <> " : " <> render expr 113 | render (CheckLock t lk) = 114 | "Check lock" <+> render lk <+> "allows" <+> render t 115 | render (UsableAtMod modality t) = 116 | "Is usable at" <+> render modality <+> render t 117 | render (DataSort _name expr) = 118 | fsep ["Sort", render expr, "allows data/record definitions"] 119 | 120 | -- | IPBoundary' 121 | instance (Render c) => Render (IPBoundary' c) where 122 | #if MIN_VERSION_Agda(2,6,4) 123 | render (IPBoundary m) = vcat $ flip fmap (Map.toList m) $ \case 124 | (boundary, rhs) -> 125 | fsep (punctuate "," xs) <+> "⊢" <+> render rhs 126 | where 127 | xs = flip fmap (IntMap.toList boundary) $ \(l, r) -> 128 | text $ concat ["@", show l, " = ", if r then "i1" else "i0"] 129 | #else 130 | render (IPBoundary eqs val meta over) = do 131 | let xs = fmap (\(l, r) -> render l <+> "=" <+> render r) eqs 132 | rhs = case over of 133 | Overapplied -> "=" <+> render meta 134 | NotOverapplied -> mempty 135 | fsep (punctuate "," xs) <+> "⊢" <+> render val <+> rhs 136 | #endif 137 | 138 | #if MIN_VERSION_Agda(2,6,4) 139 | instance Render c => Render (IPFace' c) where 140 | render (IPFace' eqs val) = do 141 | let 142 | xs = map (\ (l,r) -> render l <+> "=" <+> render r) eqs 143 | fsep (punctuate "," xs) <+> "⊢" <+> render val 144 | #endif 145 | -------------------------------------------------------------------------------- /src/Render/Internal.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | 4 | module Render.Internal where 5 | 6 | import Agda.Syntax.Common (Hiding (..), LensHiding (getHiding), Named (namedThing)) 7 | import Agda.Syntax.Internal hiding (telToList) 8 | import Agda.Utils.Function (applyWhen) 9 | import Control.Monad 10 | import qualified Data.List as List 11 | import qualified Data.Set as Set 12 | import Render.Class 13 | import Render.Common (renderHiding) 14 | import Render.Concrete () 15 | import Render.RichText 16 | 17 | -------------------------------------------------------------------------------- 18 | 19 | instance (Render a) => Render (Substitution' a) where 20 | renderPrec = pr 21 | where 22 | pr p input = case input of 23 | IdS -> "idS" 24 | EmptyS _ -> "emptyS" 25 | t :# rho -> mparens (p > 2) $ sep [pr 2 rho <> ",", renderPrec 3 t] 26 | Strengthen _ _ rho -> mparens (p > 9) $ "strS" <+> pr 10 rho 27 | Wk n rho -> mparens (p > 9) $ text ("wkS " ++ show n) <+> pr 10 rho 28 | Lift n rho -> mparens (p > 9) $ text ("liftS " ++ show n) <+> pr 10 rho 29 | 30 | -- | Term 31 | instance Render Term where 32 | renderPrec p val = 33 | case val of 34 | Var x els -> text ("@" ++ show x) `pApp` els 35 | Lam ai b -> 36 | mparens (p > 0) $ 37 | fsep 38 | [ "λ" <+> renderHiding ai id (text . absName $ b) <+> "->", 39 | render (unAbs b) 40 | ] 41 | Lit l -> render l 42 | Def q els -> render q `pApp` els 43 | Con c _ vs -> render (conName c) `pApp` vs 44 | Pi a (NoAbs _ b) -> 45 | mparens (p > 0) $ 46 | fsep 47 | [ renderPrec 1 (unDom a) <+> "->", 48 | render b 49 | ] 50 | Pi a b -> 51 | mparens (p > 0) $ 52 | fsep 53 | [ renderDom (domInfo a) (text (absName b) <+> ":" <+> render (unDom a)) <+> "->", 54 | render (unAbs b) 55 | ] 56 | Sort s -> renderPrec p s 57 | Level l -> renderPrec p l 58 | MetaV x els -> render x `pApp` els 59 | DontCare v -> renderPrec p v 60 | Dummy s es -> parens (text s) `pApp` es 61 | where 62 | pApp d els = 63 | mparens (not (null els) && p > 9) $ 64 | fsep [d, fsep (fmap (renderPrec 10) els)] 65 | 66 | instance (Render t, Render e) => Render (Dom' t e) where 67 | render dom = pTac <+> renderDom dom (render $ unDom dom) 68 | where 69 | pTac 70 | | Just t <- domTactic dom = "@" <> parens ("tactic" <+> render t) 71 | | otherwise = mempty 72 | 73 | renderDom :: (LensHiding a) => a -> Inlines -> Inlines 74 | renderDom i = 75 | case getHiding i of 76 | NotHidden -> parens 77 | Hidden -> braces 78 | Instance {} -> braces . braces 79 | 80 | instance Render Clause where 81 | render Clause {clauseTel = tel, namedClausePats = ps, clauseBody = body, clauseType = ty} = 82 | sep 83 | [ render tel <+> "|-", 84 | fsep 85 | [ fsep (fmap (renderPrec 10) ps) <+> "=", 86 | pBody body ty 87 | ] 88 | ] 89 | where 90 | pBody Nothing _ = "(absurd)" 91 | pBody (Just b) Nothing = render b 92 | pBody (Just b) (Just t) = fsep [render b <+> ":", render t] 93 | 94 | instance (Render a) => Render (Tele (Dom a)) where 95 | render tel = fsep [renderDom a (text x <+> ":" <+> render (unDom a)) | (x, a) <- telToList tel] 96 | where 97 | telToList EmptyTel = [] 98 | telToList (ExtendTel a tel') = (absName tel', a) : telToList (unAbs tel') 99 | 100 | renderPrecLevelSucs :: Int -> Integer -> (Int -> Inlines) -> Inlines 101 | renderPrecLevelSucs p 0 d = d p 102 | renderPrecLevelSucs p n d = mparens (p > 9) $ "lsuc" <+> renderPrecLevelSucs 10 (n - 1) d 103 | 104 | instance Render Level where 105 | renderPrec p (Max n as) = 106 | case as of 107 | [] -> renderN 108 | [a] | n == 0 -> renderPrec p a 109 | _ -> 110 | mparens (p > 9) $ 111 | List.foldr1 (\a b -> "lub" <+> a <+> b) $ 112 | [renderN | n > 0] ++ fmap (renderPrec 10) as 113 | where 114 | renderN = renderPrecLevelSucs p n (const "lzero") 115 | 116 | instance Render PlusLevel where 117 | renderPrec p (Plus n a) = renderPrecLevelSucs p n $ \p' -> renderPrec p' a 118 | 119 | -- instance Render LevelAtom where 120 | -- LevelAtom is just Term 121 | -- renderPrec p a = 122 | -- case a of 123 | -- MetaLevel x els -> renderPrec p (MetaV x els) 124 | -- BlockedLevel _ v -> renderPrec p v 125 | -- NeutralLevel _ v -> renderPrec p v 126 | -- UnreducedLevel v -> renderPrec p v 127 | 128 | instance Render Sort where 129 | renderPrec p = \case 130 | #if MIN_VERSION_Agda(2,6,4) 131 | Univ u (ClosedLevel n) -> text $ suffix n $ showUniv u 132 | Univ u l -> mparens (p > 9) $ text (showUniv u) <+> renderPrec 10 l 133 | Inf u n -> text $ suffix n $ showUniv u ++ "ω" 134 | LevelUniv -> "LevelUniv" 135 | #else 136 | Type (ClosedLevel 0) -> "Set" 137 | Type (ClosedLevel n) -> text $ "Set" ++ show n 138 | Type l -> mparens (p > 9) $ "Set" <+> renderPrec 10 l 139 | Prop (ClosedLevel 0) -> "Prop" 140 | Prop (ClosedLevel n) -> text $ "Prop" ++ show n 141 | Prop l -> mparens (p > 9) $ "Prop" <+> renderPrec 10 l 142 | Inf IsFibrant 0 -> "Setω" 143 | Inf IsStrict 0 -> "SSetω" 144 | Inf IsFibrant n -> text $ "Setω" ++ show n 145 | Inf IsStrict n -> text $ "SSetω" ++ show n 146 | SSet l -> mparens (p > 9) $ "SSet" <+> renderPrec 10 l 147 | #endif 148 | SizeUniv -> "SizeUniv" 149 | LockUniv -> "LockUniv" 150 | PiSort a _s1 s2 -> 151 | mparens (p > 9) $ 152 | "piSort" 153 | <+> renderDom (domInfo a) (text (absName s2) <+> ":" <+> render (unDom a)) 154 | <+> parens 155 | ( fsep 156 | [ text ("λ " ++ absName s2 ++ " ->"), 157 | render (unAbs s2) 158 | ] 159 | ) 160 | FunSort a b -> 161 | mparens (p > 9) $ 162 | "funSort" <+> renderPrec 10 a <+> renderPrec 10 b 163 | UnivSort s -> mparens (p > 9) $ "univSort" <+> renderPrec 10 s 164 | MetaS x es -> renderPrec p $ MetaV x es 165 | DefS d es -> renderPrec p $ Def d es 166 | DummyS s -> parens $ text s 167 | IntervalUniv -> "IntervalUniv" 168 | #if MIN_VERSION_Agda(2,6,4) 169 | where 170 | suffix n = applyWhen (n /= 0) (++ show n) 171 | #endif 172 | 173 | instance Render Type where 174 | renderPrec p (El _ a) = renderPrec p a 175 | 176 | instance (Render tm) => Render (Elim' tm) where 177 | renderPrec p (Apply v) = renderPrec p v 178 | renderPrec _ (Proj _o x) = "." <> render x 179 | renderPrec p (IApply _ _ r) = renderPrec p r 180 | 181 | instance Render DBPatVar where 182 | renderPrec _ x = text $ patVarNameToString (dbPatVarName x) ++ "@" ++ show (dbPatVarIndex x) 183 | 184 | instance (Render a) => Render (Pattern' a) where 185 | renderPrec n (VarP _o x) = renderPrec n x 186 | renderPrec _ (DotP _o t) = "." <> renderPrec 10 t 187 | renderPrec n (ConP c i nps) = 188 | mparens (n > 0 && not (null nps)) $ 189 | (lazy <> render (conName c)) <+> fsep (fmap (renderPrec 10) ps) 190 | where 191 | ps = fmap (fmap namedThing) nps 192 | lazy 193 | | conPLazy i = "~" 194 | | otherwise = mempty 195 | renderPrec n (DefP _ q nps) = 196 | mparens (n > 0 && not (null nps)) $ 197 | render q <+> fsep (fmap (renderPrec 10) ps) 198 | where 199 | ps = fmap (fmap namedThing) nps 200 | -- -- Version with printing record type: 201 | -- renderPrec _ (ConP c i ps) = (if b then braces else parens) $ prTy $ 202 | -- text (show $ conName c) <+> fsep (fmap (render . namedArg) ps) 203 | -- where 204 | -- b = maybe False (== ConOSystem) $ conPRecord i 205 | -- prTy d = caseMaybe (conPType i) d $ \ t -> d <+> ":" <+> render t 206 | renderPrec _ (LitP _ l) = render l 207 | renderPrec _ (ProjP _o q) = "." <> render q 208 | renderPrec n (IApplyP _o _ _ x) = renderPrec n x 209 | 210 | -------------------------------------------------------------------------------- 211 | -- Agda.Syntax.Internal.Blockers 212 | 213 | instance Render Blocker where 214 | render (UnblockOnAll us) = "all" <> parens (fsep $ punctuate "," $ map render $ Set.toList us) 215 | render (UnblockOnAny us) = "any" <> parens (fsep $ punctuate "," $ map render $ Set.toList us) 216 | render (UnblockOnMeta m) = render m 217 | render (UnblockOnProblem pid) = "problem" <+> render pid 218 | render (UnblockOnDef q) = "definition" <+> render q 219 | -------------------------------------------------------------------------------- /src/Render/Literal.hs: -------------------------------------------------------------------------------- 1 | module Render.Literal where 2 | 3 | import Agda.Syntax.Literal (Literal (..), showChar', showText) 4 | import Render.Class 5 | import Render.Common () 6 | import Render.Name () 7 | import Render.RichText 8 | 9 | -------------------------------------------------------------------------------- 10 | 11 | -- | Literal 12 | instance Render Literal where 13 | render (LitNat n) = text $ show n 14 | render (LitWord64 n) = text $ show n 15 | render (LitFloat d) = text $ show d 16 | render (LitString s) = text $ showText s "" 17 | render (LitChar c) = text $ "'" ++ showChar' c "'" 18 | render (LitQName x) = render x 19 | render (LitMeta _ x) = render x -------------------------------------------------------------------------------- /src/Render/Name.hs: -------------------------------------------------------------------------------- 1 | module Render.Name where 2 | 3 | import qualified Agda.Syntax.Abstract as A 4 | import qualified Agda.Syntax.Common as C 5 | import qualified Agda.Syntax.Concrete as C 6 | import qualified Agda.Utils.List1 as Agda 7 | import Render.Class 8 | import Render.RichText 9 | 10 | -------------------------------------------------------------------------------- 11 | 12 | -- | Concrete 13 | instance Render C.NamePart where 14 | render C.Hole = "_" 15 | render (C.Id s) = text $ C.rawNameToString s 16 | 17 | -- glueing name parts together 18 | instance Render C.Name where 19 | render (C.Name range _inScope xs) = linkRange range $ mconcat (render <$> Agda.toList xs) 20 | render (C.NoName _ _) = "_" 21 | 22 | instance Render C.QName where 23 | render (C.Qual m x) 24 | | C.isUnderscore m = render x -- don't print anonymous modules 25 | | otherwise = render m <> "." <> render x 26 | render (C.QName x) = render x 27 | 28 | -------------------------------------------------------------------------------- 29 | 30 | -- | Abstract 31 | instance Render A.Name where 32 | render = render . A.nameConcrete 33 | 34 | instance Render A.QName where 35 | render = hcat . punctuate "." . fmap render . Agda.toList . A.qnameToList 36 | -------------------------------------------------------------------------------- /src/Render/Position.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | 4 | module Render.Position where 5 | 6 | import Agda.Syntax.Position 7 | import Agda.Utils.FileName 8 | import qualified Data.Strict.Maybe as Strict 9 | import Render.Class 10 | import Render.RichText 11 | 12 | instance Render AbsolutePath where 13 | render = text . filePath 14 | 15 | instance Render RangeFile where 16 | render = render . rangeFilePath -- TODO rangeFileName ? 17 | 18 | -------------------------------------------------------------------------------- 19 | 20 | instance (Render a) => Render (Position' (Strict.Maybe a)) where 21 | render (Pn Strict.Nothing _ l c) = render l <> "," <> render c 22 | render (Pn (Strict.Just f) _ l c) = 23 | render f <> ":" <> render l <> "," <> render c 24 | 25 | instance Render PositionWithoutFile where 26 | render (Pn () _ l c) = render l <> "," <> render c 27 | 28 | instance Render IntervalWithoutFile where 29 | render (Interval s e) = start <> "-" <> end 30 | where 31 | sl = posLine s 32 | el = posLine e 33 | sc = posCol s 34 | ec = posCol e 35 | 36 | start = render sl <> "," <> render sc 37 | 38 | end 39 | | sl == el = render ec 40 | | otherwise = render el <> "," <> render ec 41 | 42 | instance (Render a) => Render (Interval' (Strict.Maybe a)) where 43 | render i@(Interval s _) = file <> render (setIntervalFile () i) 44 | where 45 | file :: Inlines 46 | file = case srcFile s of 47 | Strict.Nothing -> mempty 48 | Strict.Just f -> render f <> ":" 49 | 50 | instance (Render a) => Render (Range' (Strict.Maybe a)) where 51 | render r = maybe mempty render (rangeToIntervalWithFile r) 52 | -------------------------------------------------------------------------------- /src/Render/RichText.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | 5 | module Render.RichText 6 | ( Block (..), 7 | Inlines (..), 8 | -- LinkTarget (..), 9 | space, 10 | text, 11 | text', 12 | parens, 13 | -- link, 14 | linkRange, 15 | linkHole, 16 | icon, 17 | -- combinators 18 | (<+>), 19 | (), 20 | punctuate, 21 | braces, 22 | braces', 23 | dbraces, 24 | mparens, 25 | hcat, 26 | hsep, 27 | sep, 28 | fsep, 29 | vcat, 30 | fcat, 31 | -- symbols 32 | arrow, 33 | lambda, 34 | forallQ, 35 | showIndex, 36 | leftIdiomBrkt, 37 | rightIdiomBrkt, 38 | emptyIdiomBrkt, 39 | ) 40 | where 41 | 42 | -- import qualified Agda.Interaction.Options as Agda 43 | -- import qualified Agda.Syntax.Concrete.Glyph as Agda 44 | import qualified Agda.Syntax.Position as Agda 45 | import qualified Agda.Utils.FileName as Agda 46 | import Agda.Utils.Null 47 | import qualified Agda.Utils.Null as Agda 48 | import Agda.Utils.Suffix (toSubscriptDigit) 49 | import Data.Aeson (ToJSON (toJSON), Value (Null)) 50 | import Data.Foldable (toList) 51 | import Data.Sequence (Seq (..)) 52 | import qualified Data.Sequence as Seq 53 | import qualified Data.Strict.Maybe as Strict 54 | import Data.String (IsString (..)) 55 | import GHC.Generics (Generic) 56 | import Prelude hiding (null) 57 | 58 | -------------------------------------------------------------------------------- 59 | 60 | -- | Block elements 61 | data Block 62 | = -- for blocks like "Goal" & "Have" 63 | Labeled Inlines (Maybe String) (Maybe Agda.Range) String String 64 | | -- for ordinary goals & context 65 | Unlabeled Inlines (Maybe String) (Maybe Agda.Range) 66 | | -- headers 67 | Header String 68 | deriving (Generic) 69 | 70 | instance ToJSON Block 71 | 72 | -------------------------------------------------------------------------------- 73 | 74 | newtype Inlines = Inlines {unInlines :: Seq Inline} 75 | 76 | -- Represent Inlines with String literals 77 | instance IsString Inlines where 78 | fromString s = Inlines (Seq.singleton (Text s mempty)) 79 | 80 | instance Semigroup Inlines where 81 | Inlines as <> Inlines bs = Inlines (merge as bs) 82 | where 83 | merge :: Seq Inline -> Seq Inline -> Seq Inline 84 | merge Empty ys = ys 85 | merge (xs :|> x) ys = merge xs (cons x ys) 86 | 87 | cons :: Inline -> Seq Inline -> Seq Inline 88 | cons (Text s c) (Text t d :<| xs) 89 | -- merge 2 adjacent Text if they have the same classnames 90 | | c == d = Text (s <> t) c :<| xs 91 | | otherwise = Text s c :<| Text t d :<| xs 92 | cons (Text s c) (Horz [] :<| xs) = cons (Text s c) xs 93 | cons (Text s c) (Horz (Inlines t : ts) :<| xs) = 94 | -- merge Text with Horz when possible 95 | Horz (Inlines (cons (Text s c) t) : ts) :<| xs 96 | cons x xs = x :<| xs 97 | 98 | instance Monoid Inlines where 99 | mempty = Inlines mempty 100 | 101 | instance ToJSON Inlines where 102 | toJSON (Inlines xs) = toJSON xs 103 | 104 | instance Show Inlines where 105 | show (Inlines xs) = unwords $ map show $ toList xs 106 | 107 | instance Null Inlines where 108 | empty = mempty 109 | null (Inlines elems) = all elemIsNull (Seq.viewl elems) 110 | where 111 | elemIsNull :: Inline -> Bool 112 | elemIsNull (Icon _ _) = False 113 | elemIsNull (Text "" _) = True 114 | elemIsNull (Text _ _) = False 115 | elemIsNull (Link _ xs _) = all elemIsNull $ unInlines xs 116 | elemIsNull (Hole _) = False 117 | elemIsNull (Horz xs) = all null xs 118 | elemIsNull (Vert xs) = all null xs 119 | elemIsNull (Parn _) = False 120 | elemIsNull (PrHz _) = False 121 | 122 | -- -- | see if the rendered text is "empty" 123 | 124 | infixr 6 <+> 125 | 126 | (<+>) :: Inlines -> Inlines -> Inlines 127 | x <+> y 128 | | null x = y 129 | | null y = x 130 | | otherwise = x <> " " <> y 131 | 132 | infixl 6 133 | 134 | -- | A synonym for '<+>' at the moment 135 | () :: Inlines -> Inlines -> Inlines 136 | () = (<+>) 137 | 138 | -- | Whitespace 139 | space :: Inlines 140 | space = " " 141 | 142 | text :: String -> Inlines 143 | text s = Inlines $ Seq.singleton $ Text s mempty 144 | 145 | text' :: ClassNames -> String -> Inlines 146 | text' cs s = Inlines $ Seq.singleton $ Text s cs 147 | 148 | -- When there's only 1 Horz inside a Parn, convert it to PrHz 149 | parens :: Inlines -> Inlines 150 | parens (Inlines (Horz xs :<| Empty)) = Inlines $ Seq.singleton $ PrHz xs 151 | parens others = Inlines $ Seq.singleton $ Parn others 152 | 153 | icon :: String -> Inlines 154 | icon s = Inlines $ Seq.singleton $ Icon s [] 155 | 156 | linkRange :: Agda.Range -> Inlines -> Inlines 157 | linkRange range xs = Inlines $ Seq.singleton $ Link range xs mempty 158 | 159 | linkHole :: Int -> Inlines 160 | linkHole i = Inlines $ Seq.singleton $ Hole i 161 | 162 | -------------------------------------------------------------------------------- 163 | 164 | type ClassNames = [String] 165 | 166 | -------------------------------------------------------------------------------- 167 | 168 | -- | Internal type, to be converted to JSON values 169 | data Inline 170 | = Icon String ClassNames 171 | | Text String ClassNames 172 | | Link Agda.Range Inlines ClassNames 173 | | Hole Int 174 | | -- | Horizontal grouping, wrap when there's no space 175 | Horz [Inlines] 176 | | -- | Vertical grouping, each children would end with a newline 177 | Vert [Inlines] 178 | | -- | Parenthese 179 | Parn Inlines 180 | | -- | Parenthese around a Horizontal, special case 181 | PrHz [Inlines] 182 | deriving (Generic) 183 | 184 | instance ToJSON Inline 185 | 186 | instance Show Inline where 187 | show (Icon s _) = s 188 | show (Text s _) = s 189 | show (Link _ xs _) = mconcat (map show $ toList $ unInlines xs) 190 | show (Hole i) = "?" ++ show i 191 | show (Horz xs) = unwords (map show $ toList xs) 192 | show (Vert xs) = unlines (map show $ toList xs) 193 | show (Parn x) = "(" <> show x <> ")" 194 | show (PrHz xs) = "(" <> unwords (map show $ toList xs) <> ")" 195 | 196 | -------------------------------------------------------------------------------- 197 | 198 | -- | ToJSON instances for A.types 199 | instance {-# OVERLAPS #-} ToJSON Agda.Range 200 | 201 | instance ToJSON (Agda.Interval' ()) where 202 | toJSON (Agda.Interval start end) = toJSON (start, end) 203 | 204 | instance ToJSON (Agda.Position' ()) where 205 | toJSON (Agda.Pn () pos line col) = toJSON [line, col, pos] 206 | 207 | instance {-# OVERLAPS #-} ToJSON Agda.SrcFile where 208 | toJSON Strict.Nothing = Null 209 | toJSON (Strict.Just path) = toJSON path 210 | 211 | instance ToJSON Agda.AbsolutePath where 212 | toJSON (Agda.AbsolutePath path) = toJSON path 213 | 214 | instance ToJSON Agda.RangeFile where 215 | toJSON (Agda.RangeFile path _maybeTopLevelModuleName) = toJSON path 216 | 217 | -------------------------------------------------------------------------------- 218 | 219 | -- | Utilities / Combinators 220 | 221 | -- TODO: implement this 222 | -- Modeled after `nest` defined in ‘Text.PrettyPrint.Annotated.HughesPJ’ (pretty-1.1.3.6) 223 | -- 224 | -- Indent a Inline by a given number of positions (which may also be negative). `indent` satisfies the laws: 225 | -- 226 | -- `indent` 0 x = x 227 | -- `indent` k ( `indent` k' x) = `indent` (k+k') x 228 | -- `indent` k (x `<>` y) = `indent` k z `<>` `indent` k y 229 | -- `indent` k (x `$$` y) = `indent` k x `$$` `indent` k y 230 | -- `indent` k `empty` = `empty` 231 | -- `x <> indent k y = x <> y` , if x non-empty 232 | -- indent :: Int -> Inlines -> Inlines 233 | -- indent 0 x = x 234 | 235 | punctuate :: Inlines -> [Inlines] -> [Inlines] 236 | punctuate _ [] = [] 237 | punctuate delim xs = zipWith (<>) xs (replicate (length xs - 1) delim ++ [mempty]) 238 | 239 | -------------------------------------------------------------------------------- 240 | 241 | -- | Just pure concatenation, no grouping or whatsoever 242 | hcat :: [Inlines] -> Inlines 243 | hcat = mconcat 244 | 245 | hsep :: [Inlines] -> Inlines 246 | hsep [] = mempty 247 | hsep [x] = x 248 | hsep (x : xs) = x <+> hsep xs 249 | 250 | -------------------------------------------------------------------------------- 251 | 252 | -- | Vertical listing 253 | vcat :: [Inlines] -> Inlines 254 | vcat = Inlines . pure . Vert 255 | 256 | -- | Horizontal listing 257 | sep :: [Inlines] -> Inlines 258 | sep = Inlines . pure . Horz 259 | 260 | fsep :: [Inlines] -> Inlines 261 | fsep = sep 262 | 263 | fcat :: [Inlines] -> Inlines 264 | fcat = sep 265 | 266 | -------------------------------------------------------------------------------- 267 | 268 | -- | Single braces 269 | braces :: Inlines -> Inlines 270 | braces x = "{" <> x <> "}" 271 | 272 | -- | Double braces 273 | dbraces :: Inlines -> Inlines 274 | dbraces = _dbraces specialCharacters 275 | 276 | arrow :: Inlines 277 | arrow = _arrow specialCharacters 278 | 279 | lambda :: Inlines 280 | lambda = _lambda specialCharacters 281 | 282 | forallQ :: Inlines 283 | forallQ = _forallQ specialCharacters 284 | 285 | -- left, right, and empty idiom bracket 286 | leftIdiomBrkt, rightIdiomBrkt, emptyIdiomBrkt :: Inlines 287 | leftIdiomBrkt = _leftIdiomBrkt specialCharacters 288 | rightIdiomBrkt = _rightIdiomBrkt specialCharacters 289 | emptyIdiomBrkt = _emptyIdiomBrkt specialCharacters 290 | 291 | -- | Apply 'parens' to 'Doc' if boolean is true. 292 | mparens :: Bool -> Inlines -> Inlines 293 | mparens True = parens 294 | mparens False = id 295 | 296 | -- | From braces' 297 | braces' :: Inlines -> Inlines 298 | braces' d = 299 | let s = show d 300 | in if Agda.null s 301 | then braces d 302 | else braces (spaceIfDash (head s) <> d <> spaceIfDash (last s)) 303 | where 304 | -- Add space to avoid starting a comment (Ulf, 2010-09-13, #269) 305 | -- Andreas, 2018-07-21, #3161: Also avoid ending a comment 306 | spaceIfDash '-' = " " 307 | spaceIfDash _ = mempty 308 | 309 | -- | Shows a non-negative integer using the characters ₀-₉ instead of 310 | -- 0-9 unless the user explicitly asked us to not use any unicode characters. 311 | showIndex :: (Show i, Integral i) => i -> String 312 | showIndex = map toSubscriptDigit . show 313 | 314 | -------------------------------------------------------------------------------- 315 | -- 316 | 317 | -- | Picking the appropriate set of special characters depending on 318 | -- whether we are allowed to use unicode or have to limit ourselves 319 | -- to ascii. 320 | data SpecialCharacters = SpecialCharacters 321 | { _dbraces :: Inlines -> Inlines, 322 | _lambda :: Inlines, 323 | _arrow :: Inlines, 324 | _forallQ :: Inlines, 325 | _leftIdiomBrkt :: Inlines, 326 | _rightIdiomBrkt :: Inlines, 327 | _emptyIdiomBrkt :: Inlines 328 | } 329 | 330 | {-# NOINLINE specialCharacters #-} 331 | specialCharacters :: SpecialCharacters 332 | specialCharacters = 333 | SpecialCharacters 334 | { _dbraces = ("\x2983 " <>) . (<> " \x2984"), 335 | _lambda = "\x03bb", 336 | _arrow = "\x2192", 337 | _forallQ = "\x2200", 338 | _leftIdiomBrkt = "\x2987", 339 | _rightIdiomBrkt = "\x2988", 340 | _emptyIdiomBrkt = "\x2987\x2988" 341 | } 342 | -------------------------------------------------------------------------------- /src/Render/TypeChecking.hs: -------------------------------------------------------------------------------- 1 | module Render.TypeChecking where 2 | 3 | import Agda.Syntax.Common 4 | import Agda.TypeChecking.Monad.Base 5 | import Agda.TypeChecking.Positivity.Occurrence 6 | import Render.Class 7 | import Render.Common 8 | import Render.RichText 9 | 10 | instance Render NamedMeta where 11 | render (NamedMeta "" x) = render x 12 | render (NamedMeta "_" x) = render x 13 | render (NamedMeta s x) = "_" <> text s <> render x 14 | 15 | instance Render Occurrence where 16 | render = 17 | text . \case 18 | Unused -> "_" 19 | Mixed -> "*" 20 | JustNeg -> "-" 21 | JustPos -> "+" 22 | StrictPos -> "++" 23 | GuardPos -> "g+" 24 | 25 | instance Render ProblemId where 26 | render (ProblemId n) = render n 27 | 28 | instance Render Comparison where 29 | render CmpEq = "=" 30 | render CmpLeq = "=<" 31 | 32 | instance Render Polarity where 33 | render = 34 | text . \case 35 | Covariant -> "+" 36 | Contravariant -> "-" 37 | Invariant -> "*" 38 | Nonvariant -> "_" 39 | -------------------------------------------------------------------------------- /src/Render/Utils.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | 3 | module Render.Utils where 4 | 5 | import Agda.Utils.Time (CPUTime) 6 | #if MIN_VERSION_Agda(2,6,4) 7 | import Agda.Syntax.Common.Pretty (pretty) 8 | #else 9 | import Agda.Utils.Pretty (pretty) 10 | #endif 11 | 12 | import Render.Class 13 | import Render.RichText 14 | 15 | instance Render CPUTime where 16 | render = text . show . pretty 17 | -------------------------------------------------------------------------------- /src/Server.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | 3 | -- entry point of the LSP server 4 | 5 | module Server (run) where 6 | 7 | import qualified Agda 8 | import Control.Concurrent (writeChan) 9 | import Control.Monad (void) 10 | import Control.Monad.Reader (MonadIO (liftIO)) 11 | import Data.Aeson 12 | ( FromJSON, 13 | ToJSON, 14 | ) 15 | import qualified Data.Aeson as JSON 16 | import Data.Text (pack) 17 | import GHC.IO.IOMode (IOMode (ReadWriteMode)) 18 | import Language.LSP.Protocol.Message 19 | import Language.LSP.Protocol.Types (HoverParams (..), SaveOptions (..), TextDocumentIdentifier (..), TextDocumentSyncKind (..), TextDocumentSyncOptions (..), type (|?) (..)) 20 | import Language.LSP.Server hiding (Options) 21 | import qualified Language.LSP.Server hiding (Options) 22 | import qualified Language.LSP.Server as LSP 23 | import Monad 24 | import qualified Network.Simple.TCP as TCP 25 | import Network.Socket (socketToHandle) 26 | import Options 27 | import qualified Server.Handler as Handler 28 | import Switchboard (Switchboard, agdaCustomMethod) 29 | import qualified Switchboard 30 | 31 | -------------------------------------------------------------------------------- 32 | 33 | run :: Options -> IO Int 34 | run options = do 35 | case optViaTCP options of 36 | Just port -> do 37 | void $ 38 | TCP.serve (TCP.Host "127.0.0.1") (show port) $ 39 | \(sock, _remoteAddr) -> do 40 | -- writeChan (envLogChan env) "[Server] connection established" 41 | handle <- socketToHandle sock ReadWriteMode 42 | _ <- runServerWithHandles mempty mempty handle handle (serverDefn options) 43 | return () 44 | -- Switchboard.destroy switchboard 45 | return 0 46 | Nothing -> do 47 | runServer (serverDefn options) 48 | where 49 | serverDefn :: Options -> ServerDefinition Config 50 | serverDefn options = 51 | ServerDefinition 52 | { defaultConfig = initConfig, 53 | onConfigChange = const $ pure (), 54 | parseConfig = \old newRaw -> case JSON.fromJSON newRaw of 55 | JSON.Error s -> Left $ pack $ "Cannot parse server configuration: " <> s 56 | JSON.Success new -> Right new, 57 | doInitialize = \ctxEnv _req -> do 58 | env <- runLspT ctxEnv (createInitEnv options) 59 | switchboard <- Switchboard.new env 60 | Switchboard.setupLanguageContextEnv switchboard ctxEnv 61 | pure $ Right (ctxEnv, env), 62 | configSection = "dummy", 63 | staticHandlers = const handlers, 64 | interpretHandler = \(ctxEnv, env) -> 65 | Iso 66 | { forward = runLspT ctxEnv . runServerM env, 67 | backward = liftIO 68 | }, 69 | options = lspOptions 70 | } 71 | 72 | lspOptions :: LSP.Options 73 | lspOptions = defaultOptions {optTextDocumentSync = Just syncOptions} 74 | 75 | -- these `TextDocumentSyncOptions` are essential for receiving notifications from the client 76 | -- syncOptions :: TextDocumentSyncOptions 77 | -- syncOptions = 78 | -- TextDocumentSyncOptions 79 | -- { _openClose = Just True, -- receive open and close notifications from the client 80 | -- _change = Just changeOptions, -- receive change notifications from the client 81 | -- _willSave = Just False, -- receive willSave notifications from the client 82 | -- _willSaveWaitUntil = Just False, -- receive willSave notifications from the client 83 | -- _save = Just $ InR saveOptions 84 | -- } 85 | syncOptions :: TextDocumentSyncOptions 86 | syncOptions = 87 | TextDocumentSyncOptions 88 | { _openClose = Just True, -- receive open and close notifications from the client 89 | _change = Just TextDocumentSyncKind_Incremental, -- receive change notifications from the client 90 | _willSave = Just False, -- receive willSave notifications from the client 91 | _willSaveWaitUntil = Just False, -- receive willSave notifications from the client 92 | _save = Just $ InR $ SaveOptions (Just True) -- includes the document content on save, so that we don't have to read it from the disk (not sure if this is still true in lsp 2) 93 | } 94 | 95 | -- handlers of the LSP server 96 | handlers :: Handlers (ServerM (LspM Config)) 97 | handlers = 98 | mconcat 99 | [ -- custom methods, not part of LSP 100 | requestHandler agdaCustomMethod $ \req responder -> do 101 | let TRequestMessage _ _i _ params = req 102 | response <- Agda.sendCommand params 103 | responder $ Right response, 104 | -- `textDocument/hover` 105 | requestHandler SMethod_TextDocumentHover $ \req responder -> do 106 | let TRequestMessage _ _ _ (HoverParams (TextDocumentIdentifier uri) pos _workDone) = req 107 | result <- Handler.onHover uri pos 108 | responder $ Right result, 109 | -- -- syntax highlighting 110 | -- , requestHandler STextDocumentSemanticTokensFull $ \req responder -> do 111 | -- result <- Handler.onHighlight (req ^. (params . textDocument . uri)) 112 | -- responder result 113 | 114 | -- `initialized` 115 | notificationHandler SMethod_Initialized $ \_notification -> return (), 116 | -- `workspace/didChangeConfiguration` 117 | notificationHandler SMethod_WorkspaceDidChangeConfiguration $ \_notification -> return (), 118 | -- `textDocument/didOpen` 119 | notificationHandler SMethod_TextDocumentDidOpen $ \_notification -> return (), 120 | -- `textDocument/didClose` 121 | notificationHandler SMethod_TextDocumentDidClose $ \_notification -> return (), 122 | -- `textDocument/didChange` 123 | notificationHandler SMethod_TextDocumentDidChange $ \_notification -> return (), 124 | -- `textDocument/didSave` 125 | notificationHandler SMethod_TextDocumentDidSave $ \_notification -> return () 126 | ] -------------------------------------------------------------------------------- /src/Server/CommandController.hs: -------------------------------------------------------------------------------- 1 | module Server.CommandController 2 | ( CommandController, 3 | new, 4 | take, 5 | release, 6 | put, 7 | ) 8 | where 9 | 10 | import Agda.Interaction.Base (IOTCM) 11 | import Control.Concurrent 12 | import Control.Concurrent.SizedChan 13 | import Control.Monad (forM_) 14 | import Prelude hiding (take) 15 | 16 | data CommandController 17 | = CommandController 18 | -- | Unbounded Command queue 19 | (SizedChan IOTCM) 20 | -- | MVar for the Command consumer 21 | (MVar IOTCM) 22 | 23 | new :: IO CommandController 24 | new = CommandController <$> newSizedChan <*> newEmptyMVar 25 | 26 | -- | Blocks if the front is empty 27 | take :: CommandController -> IO IOTCM 28 | take (CommandController _ front) = takeMVar front 29 | 30 | -- | Move the payload from the queue to the front 31 | -- Does not block if the front or the queue is empty 32 | release :: CommandController -> IO () 33 | release (CommandController queue front) = do 34 | result <- tryReadSizedChan queue 35 | forM_ result (tryPutMVar front) 36 | 37 | -- | Does not block 38 | -- Move the payload to the front if the front is empty 39 | put :: CommandController -> IOTCM -> IO () 40 | put (CommandController queue front) command = do 41 | isEmpty <- isEmptyMVar front 42 | if isEmpty 43 | then putMVar front command 44 | else writeSizedChan queue command -------------------------------------------------------------------------------- /src/Server/Handler.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | 3 | module Server.Handler where 4 | 5 | import Agda ( getCommandLineOptions 6 | , runAgda 7 | ) 8 | import qualified Agda.IR as IR 9 | 10 | import Agda.Interaction.Base ( CommandQueue(..) 11 | #if MIN_VERSION_Agda(2,7,0) 12 | #else 13 | , CommandM 14 | #endif 15 | , CommandState(optionsOnReload) 16 | , Rewrite(AsIs) 17 | , initCommandState 18 | ) 19 | import Agda.Interaction.BasicOps ( atTopLevel 20 | , typeInCurrent 21 | ) 22 | import Agda.Interaction.Highlighting.Precise 23 | ( HighlightingInfo ) 24 | import qualified Agda.Interaction.Imports as Imp 25 | import Agda.Interaction.InteractionTop 26 | ( cmd_load' 27 | , localStateCommandM 28 | #if MIN_VERSION_Agda(2,7,0) 29 | , CommandM 30 | #else 31 | #endif 32 | ) 33 | import Agda.Interaction.Options ( CommandLineOptions 34 | ( optAbsoluteIncludePaths 35 | ) 36 | ) 37 | import qualified Agda.Parser as Parser 38 | import Agda.Position ( makeToOffset 39 | , toAgdaPositionWithoutFile 40 | ) 41 | import Agda.Syntax.Abstract.Pretty ( prettyATop ) 42 | import Agda.Syntax.Parser ( exprParser 43 | , parse 44 | ) 45 | import Agda.Syntax.Translation.ConcreteToAbstract 46 | ( concreteToAbstract_ ) 47 | import Agda.TypeChecking.Monad ( HasOptions(commandLineOptions) 48 | , setInteractionOutputCallback 49 | ) 50 | import Agda.TypeChecking.Warnings ( runPM ) 51 | #if MIN_VERSION_Agda(2,6,4) 52 | import Agda.Syntax.Common.Pretty ( render ) 53 | #else 54 | import Agda.Utils.Pretty ( render ) 55 | #endif 56 | import Control.Concurrent.STM 57 | import Control.Monad.Reader 58 | import Control.Monad.State 59 | import Data.Text ( Text 60 | , pack 61 | , unpack 62 | ) 63 | import qualified Data.Text as Text 64 | import Language.LSP.Server ( LspM ) 65 | import qualified Language.LSP.Server as LSP 66 | import qualified Language.LSP.Protocol.Types as LSP 67 | import qualified Language.LSP.VFS as VFS 68 | import Monad 69 | import Options ( Config 70 | , Options(optRawAgdaOptions) 71 | ) 72 | 73 | initialiseCommandQueue :: IO CommandQueue 74 | initialiseCommandQueue = CommandQueue <$> newTChanIO <*> newTVarIO Nothing 75 | 76 | runCommandM :: CommandM a -> ServerM (LspM Config) (Either String a) 77 | runCommandM program = do 78 | env <- ask 79 | runAgda $ do 80 | -- get command line options 81 | options <- getCommandLineOptions 82 | 83 | -- we need to set InteractionOutputCallback else it would panic 84 | lift $ setInteractionOutputCallback $ \_response -> return () 85 | 86 | -- setup the command state 87 | commandQueue <- liftIO initialiseCommandQueue 88 | let commandState = (initCommandState commandQueue) 89 | { optionsOnReload = options { optAbsoluteIncludePaths = [] } 90 | } 91 | 92 | lift $ evalStateT program commandState 93 | 94 | inferTypeOfText 95 | :: FilePath -> Text -> ServerM (LspM Config) (Either String String) 96 | inferTypeOfText filepath text = runCommandM $ do 97 | -- load first 98 | cmd_load' filepath [] True Imp.TypeCheck $ \_ -> return () 99 | -- infer later 100 | let norm = AsIs 101 | -- localStateCommandM: restore TC state afterwards, do we need this here? 102 | typ <- localStateCommandM $ do 103 | (e, _attrs) <- lift $ runPM $ parse exprParser (unpack text) 104 | lift $ atTopLevel $ do 105 | concreteToAbstract_ e >>= typeInCurrent norm 106 | 107 | render <$> prettyATop typ 108 | 109 | onHover :: LSP.Uri -> LSP.Position -> ServerM (LspM Config) (LSP.Hover LSP.|? LSP.Null) 110 | onHover uri pos = do 111 | result <- LSP.getVirtualFile (LSP.toNormalizedUri uri) 112 | case result of 113 | Nothing -> return $ LSP.InR LSP.Null 114 | Just file -> do 115 | let source = VFS.virtualFileText file 116 | let offsetTable = makeToOffset source 117 | let agdaPos = toAgdaPositionWithoutFile offsetTable pos 118 | lookupResult <- Parser.tokenAt uri source agdaPos 119 | case lookupResult of 120 | Nothing -> return $ LSP.InR LSP.Null 121 | Just (_token, text) -> do 122 | case LSP.uriToFilePath uri of 123 | Nothing -> return $ LSP.InR LSP.Null 124 | Just filepath -> do 125 | let range = LSP.Range pos pos 126 | inferResult <- inferTypeOfText filepath text 127 | case inferResult of 128 | Left err -> do 129 | let content = hoverContent $ "Error: " <> pack err 130 | return $ LSP.InL $ LSP.Hover content (Just range) 131 | Right typeString -> do 132 | let content = hoverContent $ pack typeString 133 | return $ LSP.InL $ LSP.Hover content (Just range) 134 | where 135 | hoverContent = 136 | LSP.InL . LSP.mkMarkdownCodeBlock "agda-language-server" 137 | -------------------------------------------------------------------------------- 138 | -- Helper functions for converting stuff to SemanticTokenAbsolute 139 | 140 | 141 | fromHighlightingInfo :: IR.HighlightingInfo -> LSP.SemanticTokenAbsolute 142 | fromHighlightingInfo (IR.HighlightingInfo start end aspects isTokenBased note defSrc) 143 | = LSP.SemanticTokenAbsolute 1 1 3 kw [] 144 | where 145 | kw = LSP.SemanticTokenTypes_Keyword 146 | 147 | -- HighlightingInfo 148 | -- Int -- starting offset 149 | -- Int -- ending offset 150 | -- [String] -- list of names of aspects 151 | -- Bool -- is token based? 152 | -- String -- note 153 | -- (Maybe (FilePath, Int)) -- the defining module of the token and its position in that module 154 | 155 | -- toToken 156 | -- :: Ranged a 157 | -- => J.SemanticTokenTypes 158 | -- -> [J.SemanticTokenModifiers] 159 | -- -> a 160 | -- -> [J.SemanticTokenAbsolute] 161 | -- toToken types modifiers x = 162 | -- let range = rangeOf x 163 | -- in [ J.SemanticTokenAbsolute (posLine (rangeStart range) - 1) 164 | -- (posCol (rangeStart range) - 1) 165 | -- (rangeSpan range) 166 | -- types 167 | -- modifiers 168 | -- ] 169 | -------------------------------------------------------------------------------- /src/Server/ResponseController.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Makes sure that all dispatched works are done. 3 | -- Notify when all dispatched works are done. 4 | module Server.ResponseController 5 | ( ResponseController, 6 | new, 7 | dispatch, 8 | setCheckpointAndWait, 9 | ) 10 | where 11 | 12 | import Control.Concurrent 13 | import Control.Concurrent.SizedChan 14 | import Control.Monad 15 | ( void, 16 | when, 17 | ) 18 | import Data.IORef 19 | 20 | data ResponseController = ResponseController 21 | { -- | The number of work dispatched 22 | dispatchedCount :: IORef Int, 23 | -- | The number of work completed 24 | completedCount :: IORef Int, 25 | -- | A channel of "Checkpoints" to be met 26 | checkpointChan :: SizedChan Checkpoint 27 | } 28 | 29 | -- | An "Checkpoint" is just a number with a callback, the callback will be invoked once the number is "met" 30 | type Checkpoint = (Int, () -> IO ()) 31 | 32 | -- | Constructs a new ResponseController 33 | new :: IO ResponseController 34 | new = ResponseController <$> newIORef 0 <*> newIORef 0 <*> newSizedChan 35 | 36 | -- | Returns a callback, invoked the callback to signal completion. 37 | -- This function and the returned callback are both non-blocking. 38 | dispatch :: ResponseController -> IO (() -> IO ()) 39 | dispatch controller = do 40 | -- bump `dispatchedCount` 41 | modifyIORef' (dispatchedCount controller) succ 42 | return $ \() -> do 43 | -- work completed, bump `completedCount` 44 | modifyIORef' (completedCount controller) succ 45 | 46 | -- see if there's any Checkpoint 47 | result <- tryPeekSizedChan (checkpointChan controller) 48 | case result of 49 | -- no checkpoints, do nothing 50 | Nothing -> return () 51 | -- a checkpoint is set! 52 | Just (dispatched, callback) -> do 53 | completed <- readIORef (completedCount controller) 54 | -- see if the checkpoint is met 55 | when (dispatched == completed) $ do 56 | -- invoke the callback and remove the checkpoint 57 | callback () 58 | void $ readSizedChan (checkpointChan controller) 59 | 60 | -- | Expects a callback, which will be invoked once all works dispatched BEFORE have been completed 61 | -- This function is non-blocking 62 | setCheckpoint :: ResponseController -> (() -> IO ()) -> IO () 63 | setCheckpoint controller callback = do 64 | dispatched <- readIORef (dispatchedCount controller) 65 | completed <- readIORef (completedCount controller) 66 | -- see if the previously dispatched works have been completed 67 | if dispatched == completed 68 | then callback () 69 | else do 70 | -- constructs a Checkpoint from `dispatchedCount` 71 | let checkpoint = (dispatched, callback) 72 | -- write it to the channel 73 | writeSizedChan (checkpointChan controller) checkpoint 74 | 75 | -- | The blocking version of `setCheckpoint` 76 | setCheckpointAndWait :: ResponseController -> IO () 77 | setCheckpointAndWait controller = do 78 | mvar <- newEmptyMVar 79 | setCheckpoint controller (putMVar mvar) 80 | takeMVar mvar 81 | -------------------------------------------------------------------------------- /src/Switchboard.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE PolyKinds #-} 4 | {-# LANGUAGE TypeApplications #-} 5 | 6 | module Switchboard (Switchboard, new, setupLanguageContextEnv, destroy, agdaCustomMethod) where 7 | 8 | import qualified Agda 9 | import Control.Concurrent 10 | import Control.Monad 11 | import Control.Monad.Reader 12 | import qualified Data.Aeson as JSON 13 | import Data.IORef 14 | import Data.Proxy (Proxy (Proxy)) 15 | import qualified Data.Text.IO as Text 16 | import Language.LSP.Protocol.Message 17 | import Language.LSP.Protocol.Types hiding 18 | ( TextDocumentSyncClientCapabilities (..), 19 | ) 20 | import Language.LSP.Server 21 | import Monad 22 | import Options (Config) 23 | import qualified Server.ResponseController as ResponseController 24 | import System.IO (stderr) 25 | 26 | data Switchboard = Switchboard 27 | { sbPrintLog :: ThreadId, 28 | sbSendResponse :: ThreadId, 29 | sbRunAgda :: ThreadId, 30 | sbLanguageContextEnv :: IORef (Maybe (LanguageContextEnv Config)) 31 | } 32 | 33 | -- | All channels go in and out from here 34 | new :: Env -> IO Switchboard 35 | new env = do 36 | ctxEnvIORef <- newIORef Nothing 37 | Switchboard 38 | <$> forkIO (keepPrintingLog env) 39 | <*> forkIO (keepSendindResponse env ctxEnvIORef) 40 | <*> forkIO (runReaderT Agda.start env) 41 | <*> pure ctxEnvIORef 42 | 43 | -- | For sending reactions to the client 44 | setupLanguageContextEnv :: Switchboard -> LanguageContextEnv Config -> IO () 45 | setupLanguageContextEnv switchboard ctxEnv = do 46 | writeIORef (sbLanguageContextEnv switchboard) (Just ctxEnv) 47 | 48 | destroy :: Switchboard -> IO () 49 | destroy switchboard = do 50 | killThread (sbPrintLog switchboard) 51 | killThread (sbSendResponse switchboard) 52 | killThread (sbRunAgda switchboard) 53 | writeIORef (sbLanguageContextEnv switchboard) Nothing 54 | 55 | -- | Keep printing log to stderr 56 | -- Consumer of `envLogChan` 57 | keepPrintingLog :: Env -> IO () 58 | keepPrintingLog env = forever $ do 59 | result <- readChan (envLogChan env) 60 | when (envDevMode env) $ do 61 | Text.hPutStrLn stderr result 62 | 63 | -- | Keep sending reactions 64 | -- Consumer of `envResponseChan` 65 | keepSendindResponse :: Env -> IORef (Maybe (LanguageContextEnv Config)) -> IO () 66 | keepSendindResponse env ctxEnvIORef = forever $ do 67 | response <- readChan (envResponseChan env) 68 | 69 | result <- readIORef ctxEnvIORef 70 | forM_ result $ \ctxEnv -> do 71 | runLspT ctxEnv $ do 72 | callback <- liftIO $ ResponseController.dispatch (envResponseController env) 73 | 74 | let value = JSON.toJSON response 75 | sendRequest agdaCustomMethod value $ \_result -> liftIO $ do 76 | -- writeChan (envLogChan env) $ "[Response] >>>> " <> pack (show value) 77 | callback () 78 | 79 | agdaCustomMethod :: SMethod ('Method_CustomMethod "agda") 80 | agdaCustomMethod = SMethod_CustomMethod (Proxy @"agda") 81 | -------------------------------------------------------------------------------- /stack-9.2-Agda-2.6.3.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-20.26 2 | compiler: ghc-9.2.8 3 | # Allow a newer minor version of GHC than the snapshot specifies 4 | compiler-check: newer-minor 5 | 6 | packages: 7 | - . 8 | 9 | extra-deps: 10 | - Agda-2.6.3 11 | - lsp-2.7.0.0@sha256:2a64b40a69fd9638056ca552d5660203019473061cff1d09dccc0c94e40a275c,3834 12 | - lsp-types-2.3.0.0@sha256:ca17a686bda5dc7ff04105ca7081dce5a90bcd050c8800a13efd68b7f0901f1c,34215 13 | - lsp-test-0.17.1.0@sha256:f54757a564b46783cf67b13f4cb4ebc45e43f5afc3604d9757ee387c091b73e9,4406 14 | - mod-0.2.0.1@sha256:eeb316fef3a8c12f4e83bbeeea748e74d75fca54d4498d574ace92e464adb05a,2409 15 | - row-types-1.0.1.2@sha256:4d4c7cb95d06a32b28ba977852d52a26b4c1f695ef083a6fd874ab6d79933b64,3071 16 | 17 | flags: 18 | agda-language-server: 19 | Agda-2-6-3: true 20 | Agda: 21 | # optimise-heavily: true 22 | enable-cluster-counting: true 23 | -------------------------------------------------------------------------------- /stack-9.2-Agda-2.6.3.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/lock_files 5 | 6 | packages: 7 | - completed: 8 | hackage: Agda-2.6.3@sha256:a668ab56534bd548c682088f595939a6b8732b46b84d7e7d808af966b5d5d4ec,36760 9 | pantry-tree: 10 | sha256: 3c60f373128b663640a90fbc6fcffcb9a5edd57e8dfc4a7b00d2f7771f9210ac 11 | size: 41559 12 | original: 13 | hackage: Agda-2.6.3 14 | - completed: 15 | hackage: lsp-2.7.0.0@sha256:2a64b40a69fd9638056ca552d5660203019473061cff1d09dccc0c94e40a275c,3834 16 | pantry-tree: 17 | sha256: 630a5e18d7783c35a296268959c8d9348ee6dc94540047ea58146b310d8de941 18 | size: 1120 19 | original: 20 | hackage: lsp-2.7.0.0@sha256:2a64b40a69fd9638056ca552d5660203019473061cff1d09dccc0c94e40a275c,3834 21 | - completed: 22 | hackage: lsp-types-2.3.0.0@sha256:ca17a686bda5dc7ff04105ca7081dce5a90bcd050c8800a13efd68b7f0901f1c,34215 23 | pantry-tree: 24 | sha256: 0bf22e394dc804c8cee74d19a7f38021cfd48a15082b39a14753c037f2a64288 25 | size: 51996 26 | original: 27 | hackage: lsp-types-2.3.0.0@sha256:ca17a686bda5dc7ff04105ca7081dce5a90bcd050c8800a13efd68b7f0901f1c,34215 28 | - completed: 29 | hackage: mod-0.2.0.1@sha256:eeb316fef3a8c12f4e83bbeeea748e74d75fca54d4498d574ace92e464adb05a,2409 30 | pantry-tree: 31 | sha256: d469d7e415c1593f052d3ca647e4085ab759be378d25ca7d2eea0aab0083ce38 32 | size: 590 33 | original: 34 | hackage: mod-0.2.0.1@sha256:eeb316fef3a8c12f4e83bbeeea748e74d75fca54d4498d574ace92e464adb05a,2409 35 | - completed: 36 | hackage: row-types-1.0.1.2@sha256:4d4c7cb95d06a32b28ba977852d52a26b4c1f695ef083a6fd874ab6d79933b64,3071 37 | pantry-tree: 38 | sha256: 6a3617038d3970095100d14d026c396002a115700500cf3004ffb67ae5a75611 39 | size: 1060 40 | original: 41 | hackage: row-types-1.0.1.2@sha256:4d4c7cb95d06a32b28ba977852d52a26b4c1f695ef083a6fd874ab6d79933b64,3071 42 | snapshots: 43 | - completed: 44 | sha256: 5a59b2a405b3aba3c00188453be172b85893cab8ebc352b1ef58b0eae5d248a2 45 | size: 650475 46 | url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/20/26.yaml 47 | original: lts-20.26 48 | -------------------------------------------------------------------------------- /stack-9.2-Agda-2.6.4.3.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-20.26 2 | compiler: ghc-9.2.8 3 | # Allow a newer minor version of GHC than the snapshot specifies 4 | compiler-check: newer-minor 5 | 6 | packages: 7 | - . 8 | 9 | extra-deps: 10 | - Agda-2.6.4.3 11 | - lsp-2.7.0.0@sha256:2a64b40a69fd9638056ca552d5660203019473061cff1d09dccc0c94e40a275c,3834 12 | - lsp-types-2.3.0.0@sha256:ca17a686bda5dc7ff04105ca7081dce5a90bcd050c8800a13efd68b7f0901f1c,34215 13 | - lsp-test-0.17.1.0@sha256:f54757a564b46783cf67b13f4cb4ebc45e43f5afc3604d9757ee387c091b73e9,4406 14 | - mod-0.2.0.1@sha256:eeb316fef3a8c12f4e83bbeeea748e74d75fca54d4498d574ace92e464adb05a,2409 15 | - row-types-1.0.1.2@sha256:4d4c7cb95d06a32b28ba977852d52a26b4c1f695ef083a6fd874ab6d79933b64,3071 16 | 17 | flags: 18 | Agda: 19 | # optimise-heavily: true 20 | enable-cluster-counting: true 21 | -------------------------------------------------------------------------------- /stack-9.2-Agda-2.6.4.3.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/lock_files 5 | 6 | packages: 7 | - completed: 8 | hackage: Agda-2.6.4.3@sha256:a8066d4b15827534d118846e98fd47bb9aadeb75e3d3b1f2c3bda8f5885c3f7c,29246 9 | pantry-tree: 10 | sha256: 8ec7c974decac30ceb45e9d728cf8b70b6da671dd80fe362e7e1fd4f0fcae77d 11 | size: 42904 12 | original: 13 | hackage: Agda-2.6.4.3 14 | - completed: 15 | hackage: lsp-2.7.0.0@sha256:2a64b40a69fd9638056ca552d5660203019473061cff1d09dccc0c94e40a275c,3834 16 | pantry-tree: 17 | sha256: 630a5e18d7783c35a296268959c8d9348ee6dc94540047ea58146b310d8de941 18 | size: 1120 19 | original: 20 | hackage: lsp-2.7.0.0@sha256:2a64b40a69fd9638056ca552d5660203019473061cff1d09dccc0c94e40a275c,3834 21 | - completed: 22 | hackage: lsp-types-2.3.0.0@sha256:ca17a686bda5dc7ff04105ca7081dce5a90bcd050c8800a13efd68b7f0901f1c,34215 23 | pantry-tree: 24 | sha256: 0bf22e394dc804c8cee74d19a7f38021cfd48a15082b39a14753c037f2a64288 25 | size: 51996 26 | original: 27 | hackage: lsp-types-2.3.0.0@sha256:ca17a686bda5dc7ff04105ca7081dce5a90bcd050c8800a13efd68b7f0901f1c,34215 28 | - completed: 29 | hackage: lsp-test-0.17.1.0@sha256:f54757a564b46783cf67b13f4cb4ebc45e43f5afc3604d9757ee387c091b73e9,4406 30 | pantry-tree: 31 | sha256: 66797a8efd50812189c410310dc0a9b72858ea3a3e78764e9cedd8f406df2564 32 | size: 1561 33 | original: 34 | hackage: lsp-test-0.17.1.0@sha256:f54757a564b46783cf67b13f4cb4ebc45e43f5afc3604d9757ee387c091b73e9,4406 35 | - completed: 36 | hackage: mod-0.2.0.1@sha256:eeb316fef3a8c12f4e83bbeeea748e74d75fca54d4498d574ace92e464adb05a,2409 37 | pantry-tree: 38 | sha256: d469d7e415c1593f052d3ca647e4085ab759be378d25ca7d2eea0aab0083ce38 39 | size: 590 40 | original: 41 | hackage: mod-0.2.0.1@sha256:eeb316fef3a8c12f4e83bbeeea748e74d75fca54d4498d574ace92e464adb05a,2409 42 | - completed: 43 | hackage: row-types-1.0.1.2@sha256:4d4c7cb95d06a32b28ba977852d52a26b4c1f695ef083a6fd874ab6d79933b64,3071 44 | pantry-tree: 45 | sha256: 6a3617038d3970095100d14d026c396002a115700500cf3004ffb67ae5a75611 46 | size: 1060 47 | original: 48 | hackage: row-types-1.0.1.2@sha256:4d4c7cb95d06a32b28ba977852d52a26b4c1f695ef083a6fd874ab6d79933b64,3071 49 | snapshots: 50 | - completed: 51 | sha256: 5a59b2a405b3aba3c00188453be172b85893cab8ebc352b1ef58b0eae5d248a2 52 | size: 650475 53 | url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/20/26.yaml 54 | original: lts-20.26 55 | -------------------------------------------------------------------------------- /stack-9.2-Agda-2.7.0.1.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-20.26 2 | compiler: ghc-9.2.8 3 | # Allow a newer minor version of GHC than the snapshot specifies 4 | compiler-check: newer-minor 5 | 6 | packages: 7 | - . 8 | 9 | extra-deps: 10 | - Agda-2.7.0.1 11 | - lsp-2.7.0.0@sha256:2a64b40a69fd9638056ca552d5660203019473061cff1d09dccc0c94e40a275c,3834 12 | - lsp-types-2.3.0.0@sha256:ca17a686bda5dc7ff04105ca7081dce5a90bcd050c8800a13efd68b7f0901f1c,34215 13 | - lsp-test-0.17.1.0@sha256:f54757a564b46783cf67b13f4cb4ebc45e43f5afc3604d9757ee387c091b73e9,4406 14 | - mod-0.2.0.1@sha256:eeb316fef3a8c12f4e83bbeeea748e74d75fca54d4498d574ace92e464adb05a,2409 15 | - row-types-1.0.1.2@sha256:4d4c7cb95d06a32b28ba977852d52a26b4c1f695ef083a6fd874ab6d79933b64,3071 16 | 17 | flags: 18 | Agda: 19 | # optimise-heavily: true 20 | enable-cluster-counting: true 21 | -------------------------------------------------------------------------------- /stack-9.2-Agda-2.7.0.1.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/lock_files 5 | 6 | packages: 7 | - completed: 8 | hackage: Agda-2.7.0.1@sha256:37d363f323c1229f9ae16b4e0b2120d713b793a012847158fe6df736ec7736ec,30433 9 | pantry-tree: 10 | sha256: c0324b33036f03017fd8b57188137d0ede9b8fbacc76876c67dd9b8b607873c7 11 | size: 43358 12 | original: 13 | hackage: Agda-2.7.0.1 14 | - completed: 15 | hackage: lsp-2.7.0.0@sha256:2a64b40a69fd9638056ca552d5660203019473061cff1d09dccc0c94e40a275c,3834 16 | pantry-tree: 17 | sha256: 630a5e18d7783c35a296268959c8d9348ee6dc94540047ea58146b310d8de941 18 | size: 1120 19 | original: 20 | hackage: lsp-2.7.0.0@sha256:2a64b40a69fd9638056ca552d5660203019473061cff1d09dccc0c94e40a275c,3834 21 | - completed: 22 | hackage: lsp-types-2.3.0.0@sha256:ca17a686bda5dc7ff04105ca7081dce5a90bcd050c8800a13efd68b7f0901f1c,34215 23 | pantry-tree: 24 | sha256: 0bf22e394dc804c8cee74d19a7f38021cfd48a15082b39a14753c037f2a64288 25 | size: 51996 26 | original: 27 | hackage: lsp-types-2.3.0.0@sha256:ca17a686bda5dc7ff04105ca7081dce5a90bcd050c8800a13efd68b7f0901f1c,34215 28 | - completed: 29 | hackage: lsp-test-0.17.1.0@sha256:f54757a564b46783cf67b13f4cb4ebc45e43f5afc3604d9757ee387c091b73e9,4406 30 | pantry-tree: 31 | sha256: 66797a8efd50812189c410310dc0a9b72858ea3a3e78764e9cedd8f406df2564 32 | size: 1561 33 | original: 34 | hackage: lsp-test-0.17.1.0@sha256:f54757a564b46783cf67b13f4cb4ebc45e43f5afc3604d9757ee387c091b73e9,4406 35 | - completed: 36 | hackage: mod-0.2.0.1@sha256:eeb316fef3a8c12f4e83bbeeea748e74d75fca54d4498d574ace92e464adb05a,2409 37 | pantry-tree: 38 | sha256: d469d7e415c1593f052d3ca647e4085ab759be378d25ca7d2eea0aab0083ce38 39 | size: 590 40 | original: 41 | hackage: mod-0.2.0.1@sha256:eeb316fef3a8c12f4e83bbeeea748e74d75fca54d4498d574ace92e464adb05a,2409 42 | - completed: 43 | hackage: row-types-1.0.1.2@sha256:4d4c7cb95d06a32b28ba977852d52a26b4c1f695ef083a6fd874ab6d79933b64,3071 44 | pantry-tree: 45 | sha256: 6a3617038d3970095100d14d026c396002a115700500cf3004ffb67ae5a75611 46 | size: 1060 47 | original: 48 | hackage: row-types-1.0.1.2@sha256:4d4c7cb95d06a32b28ba977852d52a26b4c1f695ef083a6fd874ab6d79933b64,3071 49 | snapshots: 50 | - completed: 51 | sha256: 5a59b2a405b3aba3c00188453be172b85893cab8ebc352b1ef58b0eae5d248a2 52 | size: 650475 53 | url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/20/26.yaml 54 | original: lts-20.26 55 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-20.26 2 | compiler: ghc-9.2.8 3 | # Allow a newer minor version of GHC than the snapshot specifies 4 | compiler-check: newer-minor 5 | 6 | packages: 7 | - . 8 | 9 | extra-deps: 10 | - Agda-2.7.0.1 11 | - lsp-2.7.0.0@sha256:2a64b40a69fd9638056ca552d5660203019473061cff1d09dccc0c94e40a275c,3834 12 | - lsp-types-2.3.0.0@sha256:ca17a686bda5dc7ff04105ca7081dce5a90bcd050c8800a13efd68b7f0901f1c,34215 13 | - lsp-test-0.17.1.0@sha256:f54757a564b46783cf67b13f4cb4ebc45e43f5afc3604d9757ee387c091b73e9,4406 14 | - mod-0.2.0.1@sha256:eeb316fef3a8c12f4e83bbeeea748e74d75fca54d4498d574ace92e464adb05a,2409 15 | - row-types-1.0.1.2@sha256:4d4c7cb95d06a32b28ba977852d52a26b4c1f695ef083a6fd874ab6d79933b64,3071 16 | 17 | flags: 18 | Agda: 19 | # optimise-heavily: true 20 | enable-cluster-counting: true 21 | -------------------------------------------------------------------------------- /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/lock_files 5 | 6 | packages: 7 | - completed: 8 | hackage: Agda-2.7.0.1@sha256:37d363f323c1229f9ae16b4e0b2120d713b793a012847158fe6df736ec7736ec,30433 9 | pantry-tree: 10 | sha256: c0324b33036f03017fd8b57188137d0ede9b8fbacc76876c67dd9b8b607873c7 11 | size: 43358 12 | original: 13 | hackage: Agda-2.7.0.1 14 | - completed: 15 | hackage: lsp-2.7.0.0@sha256:2a64b40a69fd9638056ca552d5660203019473061cff1d09dccc0c94e40a275c,3834 16 | pantry-tree: 17 | sha256: 630a5e18d7783c35a296268959c8d9348ee6dc94540047ea58146b310d8de941 18 | size: 1120 19 | original: 20 | hackage: lsp-2.7.0.0@sha256:2a64b40a69fd9638056ca552d5660203019473061cff1d09dccc0c94e40a275c,3834 21 | - completed: 22 | hackage: lsp-types-2.3.0.0@sha256:ca17a686bda5dc7ff04105ca7081dce5a90bcd050c8800a13efd68b7f0901f1c,34215 23 | pantry-tree: 24 | sha256: 0bf22e394dc804c8cee74d19a7f38021cfd48a15082b39a14753c037f2a64288 25 | size: 51996 26 | original: 27 | hackage: lsp-types-2.3.0.0@sha256:ca17a686bda5dc7ff04105ca7081dce5a90bcd050c8800a13efd68b7f0901f1c,34215 28 | - completed: 29 | hackage: lsp-test-0.17.1.0@sha256:f54757a564b46783cf67b13f4cb4ebc45e43f5afc3604d9757ee387c091b73e9,4406 30 | pantry-tree: 31 | sha256: 66797a8efd50812189c410310dc0a9b72858ea3a3e78764e9cedd8f406df2564 32 | size: 1561 33 | original: 34 | hackage: lsp-test-0.17.1.0@sha256:f54757a564b46783cf67b13f4cb4ebc45e43f5afc3604d9757ee387c091b73e9,4406 35 | - completed: 36 | hackage: mod-0.2.0.1@sha256:eeb316fef3a8c12f4e83bbeeea748e74d75fca54d4498d574ace92e464adb05a,2409 37 | pantry-tree: 38 | sha256: d469d7e415c1593f052d3ca647e4085ab759be378d25ca7d2eea0aab0083ce38 39 | size: 590 40 | original: 41 | hackage: mod-0.2.0.1@sha256:eeb316fef3a8c12f4e83bbeeea748e74d75fca54d4498d574ace92e464adb05a,2409 42 | - completed: 43 | hackage: row-types-1.0.1.2@sha256:4d4c7cb95d06a32b28ba977852d52a26b4c1f695ef083a6fd874ab6d79933b64,3071 44 | pantry-tree: 45 | sha256: 6a3617038d3970095100d14d026c396002a115700500cf3004ffb67ae5a75611 46 | size: 1060 47 | original: 48 | hackage: row-types-1.0.1.2@sha256:4d4c7cb95d06a32b28ba977852d52a26b4c1f695ef083a6fd874ab6d79933b64,3071 49 | snapshots: 50 | - completed: 51 | sha256: 5a59b2a405b3aba3c00188453be172b85893cab8ebc352b1ef58b0eae5d248a2 52 | size: 650475 53 | url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/20/26.yaml 54 | original: lts-20.26 55 | -------------------------------------------------------------------------------- /test/Test.hs: -------------------------------------------------------------------------------- 1 | import Data.Proxy (Proxy (..)) 2 | import Data.Typeable (Typeable) 3 | import qualified Test.LSP as LSP 4 | import qualified Test.SrcLoc as SrcLoc 5 | import Test.Tasty 6 | import Test.Tasty.Options 7 | 8 | -- Define the custom option 9 | newtype AlsPathOption = AlsPathOption FilePath 10 | deriving (Show, Typeable) 11 | 12 | instance IsOption AlsPathOption where 13 | defaultValue = AlsPathOption "als" 14 | parseValue = Just . AlsPathOption 15 | optionName = return "als-path" 16 | optionHelp = return "Path to the als executable" 17 | 18 | main :: IO () 19 | main = do 20 | let opts = [Option (Proxy :: Proxy AlsPathOption)] 21 | ingredients = includingOptions opts : defaultIngredients 22 | defaultMainWithIngredients ingredients tests 23 | 24 | tests :: TestTree 25 | tests = askOption $ \(AlsPathOption alsPath) -> 26 | testGroup 27 | "Tests" 28 | [ SrcLoc.tests, 29 | LSP.tests alsPath 30 | ] -------------------------------------------------------------------------------- /test/Test/LSP.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Test.LSP (tests) where 4 | 5 | import Agda 6 | import Control.Monad.IO.Class 7 | import qualified Data.Aeson as JSON 8 | import Language.LSP.Protocol.Message 9 | import Language.LSP.Protocol.Types 10 | import Language.LSP.Test 11 | import Switchboard (agdaCustomMethod) 12 | import Test.Tasty 13 | import Test.Tasty.HUnit 14 | 15 | tests :: FilePath -> TestTree 16 | tests alsPath = 17 | testGroup 18 | "LSP" 19 | [ testCase "load" (demo alsPath) 20 | ] 21 | 22 | demo :: FilePath -> IO () 23 | demo alsPath = do 24 | putStrLn $ "Running LSP tests on the server with the following path to the als executable: " ++ alsPath 25 | runSession alsPath fullLatestClientCaps "test/data/" $ do 26 | doc <- openDoc "A.agda" "agda" 27 | 28 | -- hover 29 | TResponseMessage _ _ rsp <- request SMethod_TextDocumentHover (HoverParams doc (Position 3 9) Nothing) 30 | case rsp of 31 | Right (InL (Hover (InL (MarkupContent _ content)) (Just (Range start end)))) -> liftIO $ do 32 | -- disregard the content of the hover message for now 33 | -- because it varies depending on the version of Agda 34 | -- content @?= "\n```agda-language-server\nAgda.Primitive.Set\n```\n" 35 | start @?= Position 3 9 36 | end @?= Position 3 9 37 | _ -> liftIO $ assertFailure "Unexpected response" 38 | 39 | -- agda-mode:load 40 | testCustomMethod "IOTCM \"test/data/A.agdaa\" NonInteractive Direct( Cmd_load \"test/data/A.agda\" [] )" 41 | 42 | -- | Sends a custom method request to the server and expects a response of `CmdRes Nothing` 43 | testCustomMethod :: String -> Session () 44 | testCustomMethod cmd = do 45 | TResponseMessage _ _ rsp <- 46 | request agdaCustomMethod $ 47 | JSON.toJSON $ 48 | CmdReq cmd 49 | liftIO $ rsp @?= Right (JSON.toJSON (CmdRes Nothing)) -------------------------------------------------------------------------------- /test/Test/SrcLoc.hs: -------------------------------------------------------------------------------- 1 | module Test.SrcLoc where 2 | 3 | import Agda.Position 4 | import qualified Data.IntMap as IntMap 5 | import Data.List (sort) 6 | import Data.Text (Text) 7 | import Test.Tasty 8 | import Test.Tasty.HUnit 9 | 10 | tests :: TestTree 11 | tests = testGroup "Source Location" [positionToOffsetTests, offsetToPositionTests] 12 | 13 | -------------------------------------------------------------------------------- 14 | 15 | positionToOffsetTests :: TestTree 16 | positionToOffsetTests = 17 | testGroup 18 | "Position => Offset" 19 | [ testCase "cached table" $ IntMap.toList (unToOffset table) @?= [(1, 4), (2, 9), (3, 12)], 20 | testCase "line 0" $ run [(0, 0), (0, 1), (0, 2), (0, 3)] @?= [0, 1, 2, 3], 21 | testCase "line 1" $ run [(1, 0), (1, 1), (1, 2), (1, 3), (1, 4)] @?= [4, 5, 6, 7, 8], 22 | testCase "line 2" $ run [(2, 0), (2, 1)] @?= [9, 10], 23 | testCase "line 3" $ run [(3, 0), (3, 1)] @?= [12, 13] 24 | ] 25 | where 26 | text :: Text 27 | text = "012\n456\r\n90\r23" 28 | 29 | table :: ToOffset 30 | table = makeToOffset text 31 | 32 | run :: [(Int, Int)] -> [Int] 33 | run = map (toOffset table) 34 | 35 | -------------------------------------------------------------------------------- 36 | 37 | offsetToPositionTests :: TestTree 38 | offsetToPositionTests = 39 | testGroup 40 | "Offset => Position" 41 | [ testCase "cached table" $ IntMap.toList (unFromOffset table) @?= [(4, 1), (9, 2), (12, 3)], 42 | testCase "line 0" $ run [0, 1, 2, 3] @?= [(0, 0), (0, 1), (0, 2), (0, 3)], 43 | testCase "line 1" $ run [4, 5, 6, 7, 8] @?= [(1, 0), (1, 1), (1, 2), (1, 3), (1, 4)], 44 | testCase "line 2" $ run [9, 10] @?= [(2, 0), (2, 1)], 45 | testCase "line 3" $ run [12, 13] @?= [(3, 0), (3, 1)] 46 | ] 47 | where 48 | text :: Text 49 | text = "012\n456\r\n90\r23" 50 | 51 | table :: FromOffset 52 | table = makeFromOffset text 53 | 54 | run :: [Int] -> [(Int, Int)] 55 | run = map (fromOffset table) 56 | -------------------------------------------------------------------------------- /test/data/A.agda: -------------------------------------------------------------------------------- 1 | module A where 2 | 3 | data ⊤ : Set where 4 | tt : ⊤ --------------------------------------------------------------------------------