├── .github ├── FUNDING.yml └── ISSUE_TEMPLATE │ ├── bug_report.md │ ├── feature_request.md │ └── question.md ├── .gitignore ├── .travis.yml ├── CHANGELOG ├── EMACS.md ├── LICENSE ├── README.md ├── Setup.hs ├── appveyor.yml ├── cbits ├── HsVersions.h ├── PosixSource.h └── hschooks.c ├── elisp ├── .gitignore ├── CHANGELOG.md ├── Cask ├── check.sh ├── haskell-simple-indent.el └── intero.el ├── gifs ├── auto-install.gif ├── completion.gif ├── flycheck.gif ├── gotodef.gif ├── stack-new.gif ├── suggestions.gif └── type-info.gif ├── images └── intero.svg ├── intero.cabal ├── src ├── Completion.hs ├── GhciFind.hs ├── GhciInfo.hs ├── GhciMonad.hs ├── GhciTags.hs ├── GhciTypes.hs ├── InteractiveUI.hs ├── Intero │ └── Compat.hs ├── Main.hs └── test │ └── Main.hs ├── stack.yaml └── test └── test-ghcs /.github/FUNDING.yml: -------------------------------------------------------------------------------- 1 | # These are supported funding model platforms 2 | 3 | patreon: chrisdone 4 | -------------------------------------------------------------------------------- /.github/ISSUE_TEMPLATE/bug_report.md: -------------------------------------------------------------------------------- 1 | --- 2 | name: Bug report 3 | about: Create a report to help us improve 4 | 5 | --- 6 | 7 | ## Problem 8 | 9 | Description of problem here. 10 | 11 | - [ ] I checked the issue tracker for existing issues about this problem. 12 | - [ ] I'm using the latest version of intero. 13 | - [ ] I am not using Nix, which is notorious for breaking stack, intero and lots of other things. 14 | - [ ] I have checked that my error is not GHC's fault by testing my project on standard GHCi. 15 | - [ ] I am using calm, polite language. 16 | - [ ] I am not trying to use intero on bleeding edge GHC (head or nightly); Intero is only developed against full GHC releases. 17 | 18 | ### Input program/project 19 | 20 | Link to sample project here. It helps to paste something on 21 | https://gist.github.com/ 22 | 23 | * If the problem occurs on any Haskell file, you can just paste a small sample Haskell file. 24 | * If the problem occurs on a specific type of project, plase consider pasting all your stack.yaml, proj.cabal and any relevant .hs files into the Gist too. 25 | 26 | That way, a maintainer can easily clone down your test case and reproduce the behavior. Issues that the maintainers can't reproduce **will probably not get fixed**. 27 | 28 | If you pressed specific Emacs keypresses, what were they? It also helps to enable debugging in Emacs with `M-x intero-toggle-debug` which will print a log of everything in `*Messages*`, which you can include in the "Actual behavior" section below in a gist. 29 | 30 | ### Expected behavior 31 | 32 | Describe what you expected. 33 | 34 | ### Actual behavior 35 | 36 | What actually happened. Include any https://gist.github.com/ links of output logs. Don't fill the issue description with output. :+1+ 37 | 38 | ### Workarounds 39 | 40 | Feel free to include any workarounds that might help other people until the issue is fixed. 41 | -------------------------------------------------------------------------------- /.github/ISSUE_TEMPLATE/feature_request.md: -------------------------------------------------------------------------------- 1 | --- 2 | name: Feature request 3 | about: Suggest an idea for this project 4 | 5 | --- 6 | 7 | **Completed checklist** 8 | 9 | - [ ] I've checked the issue tracker for similar issues. 10 | - [ ] I am not creating an issue about any of the following: 11 | - Nix integration (we do NOT support this at this time) 12 | - Cabal-install integration (we do NOT support this at this time) 13 | - Hoogle integration (we do NOT support this at this time) 14 | - hlint integration (the projects are unrelated and will remain so) 15 | 16 | **Problem description** 17 | 18 | A clear and concise description of what the problem is. 19 | 20 | **Proposed solution** 21 | 22 | A clear and concise description of what you want to happen. 23 | 24 | If you are able to implement said feature, **please say this**. Features that the maintainers don't feel like implementing **won't be implemented.** 25 | 26 | **Alternatives** 27 | 28 | A clear and concise description of any alternative solutions or features you've considered. 29 | -------------------------------------------------------------------------------- /.github/ISSUE_TEMPLATE/question.md: -------------------------------------------------------------------------------- 1 | --- 2 | name: Question 3 | about: Ask a question about intero 4 | 5 | --- 6 | 7 | ## Question 8 | 9 | 10 | 11 | Include any example project if relevant, and the intero version you're talking about. 12 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | cabal-dev 3 | *.o 4 | *.hi 5 | *.chi 6 | *.chs.h 7 | *.dyn_o 8 | *.dyn_hi 9 | .hpc 10 | .hsenv 11 | .cabal-sandbox/ 12 | cabal.sandbox.config 13 | *.prof 14 | *.aux 15 | *.hp 16 | .stack-work/ 17 | *.elc 18 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: generic 2 | sudo: false 3 | 4 | env: 5 | - RESOLVER=nightly 6 | - RESOLVER=lts-13 7 | - RESOLVER=lts-12 8 | - RESOLVER=lts-11 9 | - RESOLVER=lts-9 10 | - RESOLVER=lts-7 11 | - RESOLVER=lts-6 12 | - RESOLVER=lts-3 13 | - RESOLVER=lts-2 14 | os: 15 | - linux 16 | - osx 17 | 18 | addons: 19 | apt: 20 | packages: [libgmp-dev] 21 | 22 | matrix: 23 | exclude: 24 | # Broken on newer OS Xs 25 | - env: RESOLVER=lts-2 26 | os: osx 27 | allow_failures: 28 | - env: RESOLVER=nightly 29 | before_install: 30 | - export PATH=$HOME/.local/bin:$PATH 31 | - mkdir -p ~/.local/bin 32 | - | 33 | if [ `uname` = "Darwin" ] 34 | then 35 | travis_retry curl --insecure -L https://get.haskellstack.org/stable/osx-x86_64.tar.gz | tar xz --strip-components=1 --include '*/stack' -C ~/.local/bin 36 | else 37 | travis_retry curl -L https://get.haskellstack.org/stable/linux-x86_64.tar.gz | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack' 38 | fi 39 | 40 | script: 41 | - stack --resolver=$RESOLVER --no-terminal test 42 | #--ghc-options=-Werror 43 | 44 | cache: 45 | directories: 46 | - '$HOME/.stack' 47 | -------------------------------------------------------------------------------- /CHANGELOG: -------------------------------------------------------------------------------- 1 | 0.1.40: 2 | * Support for GHC 8.6.5 3 | 0.1.39: 4 | * Support for GHC 8.6.4 5 | 0.1.38: 6 | * Fix bug of getting encoding for networked queries 7 | 8 | 0.1.37: 9 | * Fix completion listing deferred names 10 | 11 | 0.1.36: 12 | * Fix handling of unicode for type/info queries 13 | 14 | 0.1.35: 15 | * Support for GHC 8.6.3 16 | 17 | 0.1.34: 18 | * Support for GHC 8.6.1 19 | 20 | 0.1.33: 21 | * Support for GHC 8.4.4 22 | 23 | 0.1.32: 24 | * Support for GHC 8.4.3 25 | 26 | 0.1.31: 27 | * Collecting type info no longer prints messages 28 | 29 | 0.1.29: 30 | * Support GHC 8.4 31 | 32 | 0.1.27: 33 | * Add experimental :fill command. 34 | 35 | 0.1.23: 36 | * :cd handles quoted filepaths properly 37 | 38 | 0.1.22: 39 | * Support for :move and :sleep 40 | 41 | 0.1.20: 42 | * More robust name finding, fixes bug https://github.com/commercialhaskell/intero/issues/98 43 | 44 | 0.1.19: 45 | * Support completion of qualified identifiers 46 | 47 | 0.1.18: 48 | * Completion in the REPL gets updated properly when imports 49 | added/removed https://github.com/commercialhaskell/intero/issues/112 50 | 51 | 0.1.17: 52 | * :unset -XFoo now works 53 | 54 | 0.1.16: 55 | * Re-add back collecting type info after any load 56 | 57 | 0.1.14: 58 | * Bring back :completion 59 | 60 | 0.1.13: 61 | * Fix bug in :type-at returning outer span info (https://github.com/commercialhaskell/intero/issues/47) 62 | 63 | 0.1.12: 64 | * Emacs mode automatically installs latest intero. 65 | * intero-list-buffers command. 66 | * Fix cl-case reference 67 | * Add warning when used outside of stack exec/stack ghci 68 | * Transfer to commercialhaskell 69 | 70 | 0.1.11: 71 | * Support --version 72 | 73 | 0.1.10: 74 | * Completion for module's local imports and definitions (https://github.com/chrisdone/intero/issues/31) 75 | * Starting the REPL takes the targets chosen for the backend 76 | * Prompt displays interrobang for cuteness (https://github.com/chrisdone/intero/issues/40) 77 | 78 | 0.1.9: 79 | * Support GHC 8 80 | * Fix completion before any module is loaded (https://github.com/chrisdone/intero/issues/34) 81 | * Add completion for custom commands 82 | * Add data-files entry for Emacs Lisp code 83 | * Collect type-info whenever anything is loaded (https://github.com/chrisdone/intero/issues/37) 84 | 85 | 0.1.8: 86 | * Don't use -dynamic on Windows. 87 | 88 | 0.1.7: 89 | * Remove "flags: " message 90 | 91 | 0.1.6: 92 | * Make better, more liberal :type-at (https://github.com/chrisdone/intero/issues/29) 93 | * Better argument parser for :type-at, :loc-at, :uses 94 | * Retain names that were in scope after a successful load for :complete 95 | 96 | 0.1.5: 97 | * Add upper bound for GHC (https://github.com/chrisdone/intero/issues/27) 98 | 99 | 0.1.4: 100 | * Fix cache invalidation bug for interpreted mode (https://github.com/chrisdone/intero/issues/1) 101 | 102 | 0.1.3: 103 | * Added test suite 104 | * Fix bug in :type-at that excluded a type constraint (https://github.com/chrisdone/intero/issues/14) 105 | 106 | 0.1.2: 107 | * Fixed bug in :uses, by using location equality. 108 | -------------------------------------------------------------------------------- /EMACS.md: -------------------------------------------------------------------------------- 1 | # Intero for Emacs 2 | 3 | [![MELPA](https://melpa.org/packages/intero-badge.svg)](https://melpa.org/#/intero) [![MELPA Stable](https://stable.melpa.org/packages/intero-badge.svg)](https://stable.melpa.org/#/intero) 4 | 5 | Please see 6 | [the homepage for Intero for Emacs](http://chrisdone.github.io/intero). 7 | 8 | #### Default key bindings 9 | 10 | Key binding | Description 11 | --- | --- 12 | `M-.` | Jump to definition 13 | `C-c C-i` | Show information of identifier at point 14 | `C-c C-t` | Show the type of thing at point, or the selection 15 | `C-u C-c C-t` | Insert a type signature for the thing at point 16 | `C-c C-l` | Load this module in the REPL 17 | `C-c C-c` | Evaluate the selected region in the REPL 18 | `C-c C-r` | Apply suggestions from GHC 19 | `C-c C-k` | Clear REPL 20 | `C-c C-z` | Switch to and from the REPL 21 | 22 | ## Enabling intero 23 | 24 | To enable `intero` in all `haskell-mode` buffers by default, enable 25 | `intero-global-mode`, by using `M-x customize` or by adding 26 | `(intero-global-mode 1)` to your Emacs start-up files. 27 | 28 | Intero will then activate for all projects, and for files without a 29 | stack.yaml, it will assume the "global" project. If you want to use an 30 | alternate stack yaml configuration file (for example, when developing 31 | for multiple GHC versions), use `M-x intero-stack-yaml` to switch 32 | file. When switching configuration, you will asked whether you want to 33 | preserve this choice across emacs sessions for the given project. 34 | 35 | ## Whitelisting/blacklisting projects 36 | 37 | Some users prefer to enable Intero selectively. The custom variables 38 | `intero-blacklist` and `intero-whitelist` are provided for this 39 | purpose, and are honoured by `intero-global-mode`: 40 | 41 | If the parent directory of a Haskell file is listed in 42 | `intero-blacklist`, then `intero` will not be enabled for that file, 43 | unless a parent directory of that file is also listed in 44 | `intero-whitelist`. In other words, whitelist entries take 45 | precedence. You can therefore blacklist `/` to disable `intero` in all 46 | projects unless they are whitelisted. 47 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2016, Chris Done 2 | All rights reserved. 3 | 4 | Redistribution and use in source and binary forms, with or without 5 | modification, are permitted provided that the following conditions are met: 6 | 7 | * Redistributions of source code must retain the above copyright notice, this 8 | list of conditions and the following disclaimer. 9 | 10 | * Redistributions in binary form must reproduce the above copyright notice, 11 | this list of conditions and the following disclaimer in the documentation 12 | and/or other materials provided with the distribution. 13 | 14 | * Neither the name of intero nor the names of its 15 | contributors may be used to endorse or promote products derived from 16 | this software without specific prior written permission. 17 | 18 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 19 | AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 20 | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 21 | DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE 22 | FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 23 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR 24 | SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 25 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, 26 | OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 27 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 28 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # intero [![No Maintenance Intended](http://unmaintained.tech/badge.svg)](http://unmaintained.tech/) 2 | 3 | The intero project has reached the end of its life cycle. 🌇 4 | 5 | * I will not be maintaining it any longer. 6 | * Minimal pull requests will be accepted for a few months. 7 | * After which, I will archive the project. 8 | 9 | If an individual or group would like to fork take over the project, they are welcome to do so. I will update this README to point to those alternatives. 10 | 11 | Alternatives: 12 | 13 | * [Dante](https://github.com/jyp/dante) 14 | * [haskell-ide-engine](https://github.com/haskell/haskell-ide-engine) 15 | * [ghcide](https://github.com/digital-asset/ghcide) 16 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /appveyor.yml: -------------------------------------------------------------------------------- 1 | build: off 2 | 3 | before_test: 4 | # http://help.appveyor.com/discussions/problems/6312-curl-command-not-found 5 | - set PATH=C:\Program Files\Git\mingw64\bin;%PATH% 6 | 7 | - curl -sS -ostack.zip -L --insecure https://get.haskellstack.org/stable/windows-x86_64.zip 8 | - 7z x stack.zip stack.exe 9 | 10 | clone_folder: "c:\\stack" 11 | environment: 12 | global: 13 | STACK_ROOT: "c:\\sr" 14 | TMP: "c:\\tmp" 15 | 16 | matrix: 17 | - ARGS: "--resolver lts-13" # GHC 8.6.x 18 | - ARGS: "--resolver lts-12" # GHC 8.4.x 19 | - ARGS: "--resolver lts-11" # GHC 8.2.2 20 | - ARGS: "--resolver lts-9" # GHC 8.0.2 21 | - ARGS: "--resolver lts-7" # GHC 8.0.1 22 | - ARGS: "--resolver lts-6" # GHC 7.10.3 23 | 24 | test_script: 25 | 26 | # Install toolchain, but do it silently due to lots of output 27 | - stack %ARGS% setup > nul 28 | 29 | # The ugly echo "" hack is to avoid complaints about 0 being an invalid file 30 | # descriptor 31 | - echo "" | stack %ARGS% --no-terminal test --verbosity=error 32 | #--ghc-options=-Werror 33 | -------------------------------------------------------------------------------- /cbits/HsVersions.h: -------------------------------------------------------------------------------- 1 | /* Hack needed because of http://hackage.haskell.org/trac/ghc/ticket/8040 */ 2 | 3 | #define ASSERT(e) if debugIsOn && not (e) then (assertPanic __FILE__ __LINE__) else 4 | 5 | #define GLOBAL_VAR(name,value,ty) \ 6 | {-# NOINLINE name #-}; \ 7 | name :: IORef (ty); \ 8 | name = Util.global (value); 9 | -------------------------------------------------------------------------------- /cbits/PosixSource.h: -------------------------------------------------------------------------------- 1 | /* ----------------------------------------------------------------------------- 2 | * 3 | * (c) The GHC Team, 1998-2005 4 | * 5 | * Include this file into sources which should not need any non-Posix services. 6 | * That includes most RTS C sources. 7 | * ---------------------------------------------------------------------------*/ 8 | 9 | #ifndef POSIXSOURCE_H 10 | #define POSIXSOURCE_H 11 | 12 | #include 13 | 14 | #if defined(freebsd_HOST_OS) || defined(dragonfly_HOST_OS) 15 | #define _POSIX_C_SOURCE 200112L 16 | #define _XOPEN_SOURCE 600 17 | #else 18 | #define _POSIX_SOURCE 1 19 | #define _POSIX_C_SOURCE 199506L 20 | #define _XOPEN_SOURCE 500 21 | // FreeBSD takes a different approach to _ISOC99_SOURCE: on FreeBSD it 22 | // means "I want *just* C99 things", whereas on GNU libc and Solaris 23 | // it means "I also want C99 things". 24 | // 25 | // On both GNU libc and FreeBSD, _ISOC99_SOURCE is implied by 26 | // _XOPEN_SOURCE==600, but on Solaris it is an error to omit it. 27 | #define _ISOC99_SOURCE 28 | // Defining __USE_MINGW_ANSI_STDIO is the most portable way to tell 29 | // mingw that we want to use the standard %lld style format specifiers, 30 | // rather than the Windows %I64d style 31 | #define __USE_MINGW_ANSI_STDIO 1 32 | #endif 33 | 34 | #if defined(darwin_HOST_OS) 35 | /* If we don't define this the including sysctl breaks with things like 36 | /usr/include/bsm/audit.h:224:0: 37 | error: syntax error before 'u_char' 38 | */ 39 | #define _DARWIN_C_SOURCE 1 40 | #endif 41 | 42 | #endif /* POSIXSOURCE_H */ 43 | -------------------------------------------------------------------------------- /cbits/hschooks.c: -------------------------------------------------------------------------------- 1 | /* 2 | These routines customise the error messages 3 | for various bits of the RTS. They are linked 4 | in instead of the defaults. 5 | */ 6 | 7 | #include "PosixSource.h" 8 | #include "Rts.h" 9 | 10 | #include "HsFFI.h" 11 | 12 | #include 13 | 14 | #ifdef HAVE_UNISTD_H 15 | #include 16 | #endif 17 | 18 | void 19 | initGCStatistics(void) 20 | { 21 | /* Workaround for #8754: if the GC stats aren't enabled because the 22 | compiler couldn't use -Bsymbolic to link the default hooks, then 23 | initialize them sensibly. See Note [-Bsymbolic and hooks] in 24 | Main.hs. */ 25 | if (RtsFlags.GcFlags.giveStats == NO_GC_STATS) { 26 | RtsFlags.GcFlags.giveStats = COLLECT_GC_STATS; 27 | } 28 | } 29 | 30 | void 31 | defaultsHook (void) 32 | { 33 | #if __GLASGOW_HASKELL__ >= 707 && __GLASGOW_HASKELL__ < 802 34 | // This helps particularly with large compiles, but didn't work 35 | // very well with earlier GHCs because it caused large amounts of 36 | // fragmentation. See rts/sm/BlockAlloc.c:allocLargeChunk(). 37 | RtsFlags.GcFlags.heapSizeSuggestionAuto = rtsTrue; 38 | #else 39 | RtsFlags.GcFlags.heapSizeSuggestion = 6*1024*1024 / BLOCK_SIZE; 40 | #endif 41 | 42 | RtsFlags.GcFlags.maxStkSize = 512*1024*1024 / sizeof(W_); 43 | 44 | initGCStatistics(); 45 | 46 | // See #3408: the default idle GC time of 0.3s is too short on 47 | // Windows where we receive console events once per second or so. 48 | #if __GLASGOW_HASKELL__ >= 703 49 | RtsFlags.GcFlags.idleGCDelayTime = SecondsToTime(5); 50 | #else 51 | RtsFlags.GcFlags.idleGCDelayTime = 5*1000; 52 | #endif 53 | } 54 | 55 | void 56 | StackOverflowHook (StgWord stack_size) /* in bytes */ 57 | { 58 | fprintf(stderr, "GHC stack-space overflow: current limit is %zu bytes.\nUse the `-K' option to increase it.\n", (size_t)stack_size); 59 | } 60 | -------------------------------------------------------------------------------- /elisp/.gitignore: -------------------------------------------------------------------------------- 1 | /.cask/ 2 | -------------------------------------------------------------------------------- /elisp/CHANGELOG.md: -------------------------------------------------------------------------------- 1 | # June-July 2016 2 | 3 | Intero was made public in the start of June. Here's a rundown of 4 | the changes made since then: 5 | 6 | * Now when the backend fails to start, it stops retrying when 7 | you're working until you kill the buffer. 8 | * When the backend is starting and it fails due to missing 9 | dependencies, it automatically re-runs without passing 10 | `--no-build` to stack; leading to build all the dependencies and 11 | then starting. This leads to a nice workflow of adding a package 12 | to the `.cabal` file and hitting `M-x intero-restart`. 13 | * Auto-completion of imports and pragmas. 14 | * Company-mode integration is asynchronous now, so it doesn't lock 15 | up the editor. 16 | * Removed hlint from next-checkers as it was bothering 17 | people. It's easy to re-enable 18 | [with standard flycheck](https://github.com/commercialhaskell/intero/issues/126#issuecomment-228612696) 19 | settings. 20 | * Now you can switch targets (e.g. `M-x intero-targets`) using the 21 | multi-switch view, 22 | [like this](https://github.com/commercialhaskell/intero/issues/56#issuecomment-229305346). Saves 23 | you having to remember your targets and the syntax for 24 | specifying them. 25 | * You can now launch the REPL with `C-u` prefix so that it pops up 26 | [an options list](https://github.com/commercialhaskell/intero/pull/131#issuecomment-229275383) 27 | on how to start the REPL. 28 | * Fixed a bug in the warnings parser. 29 | * Added `intero-toggle-debug` 30 | ([#79](https://github.com/commercialhaskell/intero/issues/79), 31 | [#151](https://github.com/commercialhaskell/intero/pull/151)), 32 | good for debugging issues with Intero. 33 | * Finally made a reliable way to save the current buffer for 34 | flycheck. This no longer interacts badly with magit or external 35 | changes to your files. 36 | * Added `C-c C-z` to switch to and from the REPL. 37 | * Added 38 | [a suggestions system](https://haskell-lang.org/intero#suggestions). When 39 | you hit `C-c C-r`, you get a list of suggestions that you can 40 | check and then apply with `C-c C-c`: 41 | 42 | * Automatically add extensions when GHC suggests them. Example: 43 | 44 | Can't make a derived instance of ‘Functor X’: 45 | You need DeriveFunctor to derive an instance for this class 46 | Try GeneralizedNewtypeDeriving for GHC's newtype-deriving extension 47 | In the newtype declaration for ‘X’ 48 | * Automatically remove redundant imports. Example: 49 | 50 | The import of ‘Control.Monad’ is redundant 51 | except perhaps to import instances from ‘Control.Monad’ 52 | To import instances alone, use: import Control.Monad()... (intero) 53 | * Fix typos. Example: 54 | 55 | Not in scope: ‘putStrn’ 56 | Perhaps you meant one of these: 57 | ‘putStr’ (imported from Prelude), 58 | ‘putStrLn’ (imported from Prelude) 59 | * Adding top-level type signatures. Example: 60 | 61 | Top-level binding with no type signature: main :: IO () 62 | * Removing redundant class constraints. Example: 63 | 64 | Redundant constraints: (Arith var, Bitwise var) 65 | * And turning off warnings for name shadowing and type 66 | defaulting. (Checkbox is not checked by default.) 67 | * And other miscellaneous bug fixes. 68 | -------------------------------------------------------------------------------- /elisp/Cask: -------------------------------------------------------------------------------- 1 | (source gnu) 2 | (source melpa) 3 | 4 | (package-file "intero.el") 5 | 6 | (development 7 | (depends-on "package-lint")) 8 | -------------------------------------------------------------------------------- /elisp/check.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh -e 2 | 3 | ELDIR=$(dirname "$0") 4 | 5 | INIT_PACKAGE_EL="(progn 6 | (require 'package) 7 | (push '(\"melpa\" . \"https://melpa.org/packages/\") package-archives) 8 | (package-initialize) 9 | (package-refresh-contents))" 10 | 11 | cd "$ELDIR" 12 | echo '*** INSTALLING ELISP PREREQUISITES' 13 | cask && echo OK 14 | 15 | echo 16 | echo '*** CHECKING ELISP BYTE-COMPILES CLEANLY' 17 | cask emacs -Q --eval "(setq byte-compile-error-on-warn t)" \ 18 | -batch -f batch-byte-compile ./*.el && echo OK 19 | 20 | echo 21 | echo '*** CHECKING ELISP FOR PACKAGING ISSUES' 22 | cask emacs -Q --eval "$INIT_PACKAGE_EL" \ 23 | -batch -l package-lint -f package-lint-batch-and-exit intero.el && echo OK 24 | 25 | -------------------------------------------------------------------------------- /elisp/haskell-simple-indent.el: -------------------------------------------------------------------------------- 1 | ;;; haskell-simple-indent.el --- Simple indentation module for Haskell Mode -*- lexical-binding: t -*- 2 | 3 | ;; Copyright (C) 1998 Heribert Schuetz, Graeme E Moss 4 | 5 | ;; Author: Heribert Schuetz 6 | ;; Graeme E Moss 7 | ;; Keywords: indentation files Haskell 8 | 9 | ;; This file is not part of GNU Emacs. 10 | 11 | ;; This file is free software; you can redistribute it and/or modify 12 | ;; it under the terms of the GNU General Public License as published by 13 | ;; the Free Software Foundation; either version 3, or (at your option) 14 | ;; any later version. 15 | 16 | ;; This file is distributed in the hope that it will be useful, 17 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of 18 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 19 | ;; GNU General Public License for more details. 20 | 21 | ;; You should have received a copy of the GNU General Public License 22 | ;; along with this program. If not, see . 23 | 24 | ;;; Commentary: 25 | 26 | ;; Purpose: 27 | ;; 28 | ;; To support simple indentation of Haskell scripts. 29 | ;; 30 | ;; 31 | ;; Installation: 32 | ;; 33 | ;; To bind TAB to the indentation command for all Haskell buffers, add 34 | ;; this to .emacs: 35 | ;; 36 | ;; (add-hook 'haskell-mode-hook 'turn-on-haskell-simple-indent) 37 | ;; 38 | ;; Otherwise, call `turn-on-haskell-simple-indent'. 39 | ;; 40 | ;; 41 | ;; Customisation: 42 | ;; 43 | ;; None supported. 44 | ;; 45 | ;; 46 | ;; History: 47 | ;; 48 | ;; If you have any problems or suggestions, after consulting the list 49 | ;; below, email gem@cs.york.ac.uk quoting the version of you are 50 | ;; using, the version of Emacs you are using, and a small example of 51 | ;; the problem or suggestion. 52 | ;; 53 | ;; Version 1.0: 54 | ;; Brought over from Haskell mode v1.1. 55 | ;; 56 | ;; Present Limitations/Future Work (contributions are most welcome!): 57 | ;; 58 | ;; (None so far.) 59 | 60 | ;;; Code: 61 | 62 | ;; All functions/variables start with 63 | ;; `(turn-(on/off)-)haskell-simple-indent'. 64 | 65 | (require 'haskell-mode) 66 | 67 | ;;;###autoload 68 | (defgroup haskell-simple-indent nil 69 | "Simple Haskell indentation." 70 | :link '(custom-manual "(haskell-mode)Indentation") 71 | :group 'haskell 72 | :prefix "haskell-simple-indent-") 73 | 74 | ;; Version. 75 | (defconst haskell-simple-indent-version "1.2" 76 | "`haskell-simple-indent' version number.") 77 | (defun haskell-simple-indent-version () 78 | "Echo the current version of `haskell-simple-indent' in the minibuffer." 79 | (interactive) 80 | (message "Using haskell-simple-indent version %s" 81 | haskell-simple-indent-version)) 82 | 83 | ;; Partly stolen from `indent-relative' in indent.el: 84 | (defun haskell-simple-indent () 85 | "Space out to under next visible indent point. 86 | 87 | Indent points are positions of non-whitespace following 88 | whitespace in lines preceeding point. Example: 89 | 90 | func arg cx = when (isTrue) $ do 91 | print 42 92 | ^ ^ ^ ^ ^ ^ ^ ^ ^ ^ 93 | 94 | A position is visible if it is to the left of the first 95 | non-whitespace (indentation) of every nonblank line between the 96 | position and the current line. If there is no visible indent 97 | point beyond the current column, position given by 98 | `indent-next-tab-stop' is used instead." 99 | (interactive) 100 | (let* ((start-column (or (save-excursion 101 | (back-to-indentation) 102 | (if (not (eolp)) 103 | (current-column))) 104 | (current-column))) 105 | (invisible-from nil) ; `nil' means infinity here 106 | (found) 107 | (indent)) 108 | (save-excursion 109 | ;; Loop stops if there no more lines above this one or when has 110 | ;; found a line starting at first column. 111 | (while (and (not found) 112 | (or (not invisible-from) 113 | (not (zerop invisible-from))) 114 | (zerop (forward-line -1))) 115 | ;; Ignore empty lines. 116 | (if (not (looking-at "[ \t]*\n")) 117 | (let ((this-indentation (current-indentation))) 118 | ;; Is this line so indented that it cannot have 119 | ;; influence on indentation points? 120 | (if (or (not invisible-from) 121 | (< this-indentation invisible-from)) 122 | (if (> this-indentation start-column) 123 | (setq invisible-from this-indentation) 124 | (let ((end (line-end-position))) 125 | (move-to-column start-column) 126 | ;; Is start-column inside a tab on this line? 127 | (if (> (current-column) start-column) 128 | (backward-char 1)) 129 | ;; Skip to the end of non-whitespace. 130 | (skip-chars-forward "^ \t" end) 131 | ;; Skip over whitespace. 132 | (skip-chars-forward " \t" end) 133 | ;; Indentation point found if not at the end of 134 | ;; line and if not covered by any line below 135 | ;; this one. In that case use invisible-from. 136 | (setq indent (if (or (= (point) end) 137 | (and invisible-from 138 | (> (current-column) invisible-from))) 139 | invisible-from 140 | (current-column))) 141 | ;; Signal that solution is found. 142 | (setq found t)))))))) 143 | 144 | 145 | (let ((opoint (point-marker))) 146 | ;; Indent to the calculated indent or last know invisible-from 147 | ;; or use tab-to-tab-stop. Try hard to keep cursor in the same 148 | ;; place or move it to the indentation if it was before it. And 149 | ;; keep content of the line intact. 150 | (setq indent (or indent 151 | invisible-from 152 | (if (fboundp 'indent-next-tab-stop) 153 | (indent-next-tab-stop start-column)) 154 | (let ((tabs tab-stop-list)) 155 | (while (and tabs (>= start-column (car tabs))) 156 | (setq tabs (cdr tabs))) 157 | (if tabs (car tabs))) 158 | (* (/ (+ start-column tab-width) tab-width) tab-width))) 159 | (indent-line-to indent) 160 | (if (> opoint (point)) 161 | (goto-char opoint)) 162 | (set-marker opoint nil)))) 163 | 164 | (defun haskell-simple-indent-backtab () 165 | "Indent backwards. Dual to `haskell-simple-indent'." 166 | (interactive) 167 | (let ((saved-column (or (save-excursion 168 | (back-to-indentation) 169 | (if (not (eolp)) 170 | (current-column))) 171 | (current-column))) 172 | (i 0) 173 | (x 0)) 174 | 175 | (save-excursion 176 | (back-to-indentation) 177 | (delete-region (line-beginning-position) (point))) 178 | (while (< (or (save-excursion 179 | (back-to-indentation) 180 | (if (not (eolp)) 181 | (current-column))) 182 | (current-column)) saved-column) 183 | (haskell-simple-indent) 184 | (setq i (+ i 1))) 185 | 186 | (save-excursion 187 | (back-to-indentation) 188 | (delete-region (line-beginning-position) (point))) 189 | (while (< x (- i 1)) 190 | (haskell-simple-indent) 191 | (setq x (+ x 1))))) 192 | 193 | (defun haskell-simple-indent-newline-same-col () 194 | "Make a newline and go to the same column as the current line." 195 | (interactive) 196 | (let ((start-end 197 | (save-excursion 198 | (let* ((start (line-beginning-position)) 199 | (end (progn (goto-char start) 200 | (search-forward-regexp 201 | "[^ ]" (line-end-position) t 1)))) 202 | (when end (cons start (1- end))))))) 203 | (if start-end 204 | (progn (newline) 205 | (insert (buffer-substring-no-properties 206 | (car start-end) (cdr start-end)))) 207 | (newline)))) 208 | 209 | (defun haskell-simple-indent-newline-indent () 210 | "Make a newline on the current column and indent on step." 211 | (interactive) 212 | (haskell-simple-indent-newline-same-col) 213 | (insert (make-string haskell-indent-spaces ? ))) 214 | 215 | (defun haskell-simple-indent-comment-indent-function () 216 | "Haskell version of `comment-indent-function'." 217 | ;; This is required when filladapt is turned off. Without it, when 218 | ;; filladapt is not used, comments which start in column zero 219 | ;; cascade one character to the right 220 | (save-excursion 221 | (beginning-of-line) 222 | (let ((eol (line-end-position))) 223 | (and comment-start-skip 224 | (re-search-forward comment-start-skip eol t) 225 | (setq eol (match-beginning 0))) 226 | (goto-char eol) 227 | (skip-chars-backward " \t") 228 | (max comment-column (+ (current-column) (if (bolp) 0 1)))))) 229 | 230 | ;;;###autoload 231 | (define-minor-mode haskell-simple-indent-mode 232 | "Simple Haskell indentation mode that uses simple heuristic. 233 | In this minor mode, `indent-for-tab-command' (bound to by 234 | default) will move the cursor to the next indent point in the 235 | previous nonblank line, whereas `haskell-simple-indent-backtab' 236 | \ (bound to by default) will move the cursor the 237 | previous indent point. An indent point is a non-whitespace 238 | character following whitespace. 239 | 240 | Runs `haskell-simple-indent-hook' on activation." 241 | :lighter " Ind" 242 | :group 'haskell-simple-indent 243 | :keymap '(([backtab] . haskell-simple-indent-backtab)) 244 | (kill-local-variable 'comment-indent-function) 245 | (kill-local-variable 'indent-line-function) 246 | (when haskell-simple-indent-mode 247 | (when (and (bound-and-true-p haskell-indentation-mode) 248 | (fboundp 'haskell-indentation-mode)) 249 | (haskell-indentation-mode 0)) 250 | (set (make-local-variable 'comment-indent-function) #'haskell-simple-indent-comment-indent-function) 251 | (set (make-local-variable 'indent-line-function) 'haskell-simple-indent) 252 | (run-hooks 'haskell-simple-indent-hook))) 253 | 254 | ;; The main functions. 255 | ;;;###autoload 256 | (defun turn-on-haskell-simple-indent () 257 | "Turn on function `haskell-simple-indent-mode'." 258 | (interactive) 259 | (haskell-simple-indent-mode)) 260 | (make-obsolete 'turn-on-haskell-simple-indent 261 | 'haskell-simple-indent-mode 262 | "2015-07-23") 263 | 264 | (defun turn-off-haskell-simple-indent () 265 | "Turn off function `haskell-simple-indent-mode'." 266 | (interactive) 267 | (haskell-simple-indent-mode 0)) 268 | 269 | ;; Provide ourselves: 270 | 271 | (provide 'haskell-simple-indent) 272 | 273 | ;;; haskell-simple-indent.el ends here 274 | -------------------------------------------------------------------------------- /gifs/auto-install.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/chrisdone-archive/intero/fdb0550a2ddb5692d470336aa4a057717d572695/gifs/auto-install.gif -------------------------------------------------------------------------------- /gifs/completion.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/chrisdone-archive/intero/fdb0550a2ddb5692d470336aa4a057717d572695/gifs/completion.gif -------------------------------------------------------------------------------- /gifs/flycheck.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/chrisdone-archive/intero/fdb0550a2ddb5692d470336aa4a057717d572695/gifs/flycheck.gif -------------------------------------------------------------------------------- /gifs/gotodef.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/chrisdone-archive/intero/fdb0550a2ddb5692d470336aa4a057717d572695/gifs/gotodef.gif -------------------------------------------------------------------------------- /gifs/stack-new.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/chrisdone-archive/intero/fdb0550a2ddb5692d470336aa4a057717d572695/gifs/stack-new.gif -------------------------------------------------------------------------------- /gifs/suggestions.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/chrisdone-archive/intero/fdb0550a2ddb5692d470336aa4a057717d572695/gifs/suggestions.gif -------------------------------------------------------------------------------- /gifs/type-info.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/chrisdone-archive/intero/fdb0550a2ddb5692d470336aa4a057717d572695/gifs/type-info.gif -------------------------------------------------------------------------------- /images/intero.svg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/chrisdone-archive/intero/fdb0550a2ddb5692d470336aa4a057717d572695/images/intero.svg -------------------------------------------------------------------------------- /intero.cabal: -------------------------------------------------------------------------------- 1 | name: 2 | intero 3 | version: 4 | 0.1.40 5 | synopsis: 6 | Complete interactive development program for Haskell 7 | license: 8 | BSD3 9 | homepage: 10 | https://github.com/commercialhaskell/intero 11 | license-file: 12 | LICENSE 13 | author: 14 | Chris Done, The University of Glasgow 15 | maintainer: 16 | chrisdone@fpcomplete.com 17 | copyright: 18 | 2016 FP Complete, 19 | 2016 Chris Done, 20 | 2012 Kazu Yamamoto, 21 | 2008 Claus Reinke, 22 | 2005 The University of Glasgow 23 | category: 24 | Development 25 | build-type: 26 | Simple 27 | cabal-version: 28 | >= 1.14 29 | stability: 30 | Stable 31 | extra-source-files: 32 | cbits/HsVersions.h 33 | cbits/PosixSource.h 34 | CHANGELOG 35 | README.md 36 | data-files: 37 | elisp/*.el 38 | source-repository head 39 | type: 40 | git 41 | location: 42 | git://github.com/commercialhaskell/intero.git 43 | 44 | executable intero 45 | default-language: 46 | Haskell2010 47 | main-is: 48 | Main.hs 49 | ghc-options: 50 | -Wall -O2 -threaded -rtsopts 51 | include-dirs: 52 | cbits/ 53 | hs-source-dirs: 54 | src/ 55 | c-sources: 56 | cbits/hschooks.c 57 | cpp-options: 58 | -DGHCI 59 | cc-options: 60 | -fPIC 61 | other-modules: 62 | InteractiveUI 63 | GhciMonad 64 | GhciTags 65 | GhciTypes 66 | GhciInfo 67 | GhciFind 68 | Intero.Compat 69 | Paths_intero 70 | build-depends: 71 | base < 5, 72 | array, 73 | bytestring, 74 | directory, 75 | filepath, 76 | ghc >= 7.8 && <= 8.6.5, 77 | ghc-paths, 78 | haskeline, 79 | process, 80 | transformers, 81 | syb, 82 | containers, 83 | time, 84 | network, 85 | random, 86 | mtl 87 | 88 | if impl(ghc>=8.2.2) 89 | other-modules: 90 | Completion 91 | 92 | if impl(ghc>=8.0.1) 93 | build-depends: 94 | ghci, 95 | ghc-boot-th 96 | 97 | if os(windows) 98 | build-depends: 99 | Win32 100 | else 101 | build-depends: 102 | unix 103 | ghc-options: 104 | -dynamic 105 | 106 | test-suite intero-test 107 | default-language: 108 | Haskell2010 109 | type: 110 | exitcode-stdio-1.0 111 | hs-source-dirs: 112 | src/test 113 | main-is: 114 | Main.hs 115 | build-depends: 116 | base, 117 | hspec, 118 | temporary, 119 | process, 120 | transformers, 121 | directory, 122 | regex-compat, 123 | filepath 124 | -------------------------------------------------------------------------------- /src/Completion.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | {-# LANGUAGE CPP #-} 3 | {-# LANGUAGE ViewPatterns #-} 4 | {-# LANGUAGE FlexibleContexts #-} 5 | {-# LANGUAGE ScopedTypeVariables #-} 6 | {-# LANGUAGE TupleSections #-} 7 | {-# LANGUAGE LambdaCase #-} 8 | 9 | -- | A GHC code completion module. 10 | 11 | module Completion 12 | ( getCompletableModule 13 | , declarationByLine 14 | , declarationHoles 15 | , holeSubstitutions 16 | , Declaration(..) 17 | , Hole(..) 18 | , Substitution(..) 19 | , LineNumber(..) 20 | ) where 21 | 22 | import Bag 23 | import Control.Monad 24 | import Control.Monad.IO.Class 25 | import Control.Monad.State 26 | import Data.Generics 27 | import Data.List 28 | import qualified Data.Map.Strict as M 29 | import Data.Maybe 30 | import Data.Ord 31 | import DynFlags 32 | import FastString 33 | import GHC 34 | import HscTypes 35 | import Intero.Compat 36 | import Name 37 | import OccName 38 | import Outputable 39 | import RdrName 40 | import TcRnDriver 41 | import TcRnTypes (tcg_rdr_env) 42 | import TyCoRep 43 | import TysWiredIn 44 | import Unify 45 | import Unique 46 | import Var 47 | 48 | -------------------------------------------------------------------------------- 49 | -- Types 50 | 51 | -- | A module which can be completed. Cannot contain type errors, 52 | -- including deferred ones. 53 | data CompletableModule = 54 | CompletableModule TypecheckedModule 55 | 56 | -- | All the context we need to generate completions for a declaration 57 | -- in a module. 58 | data Declaration = Declaration 59 | { declarationBind :: !(HsBindLR StageReaderName StageReaderName) 60 | -- ^ The actual declaration, which we use to find holes and 61 | -- substitute them with candidate replacements. 62 | -- ^ A sample source, which we use merely for debugging. 63 | , declarationRealSrcSpan :: !RealSrcSpan 64 | -- ^ A source span which we can provide to the client IDE. 65 | , declarationParsedModule :: !ParsedModule 66 | -- ^ The declaration belongs to a parsed module which we'll use to 67 | -- try out alterations to the tree and see if they type-check. 68 | , declarationRenamedModule :: !RenamedSource 69 | -- ^ The renamed module contains 'UnboundedVar', which marks a hole. 70 | , declarationModuleInfo :: !ModuleInfo 71 | , declarationTypecheckedModule :: !TypecheckedSource 72 | -- ^ Used to get type of holes. 73 | , declarationGlobalRdrEnv :: !GlobalRdrEnv 74 | } 75 | 76 | instance Show Declaration where 77 | showsPrec p (Declaration b real _parsedModule _renamedSource _ _ _) = 78 | showString "Declaration {declarationBind = " . 79 | gshows b . 80 | showString ", declarationRealSrcSpan = " . 81 | showsPrec (p + 1) real . showString "}" 82 | 83 | -- | An identifier for a declaration in the module. 84 | newtype DeclarationId = DeclarationId String 85 | deriving (Show) 86 | 87 | -- | Line number from the module. 88 | newtype LineNumber = LineNumber Int 89 | deriving (Show) 90 | 91 | -- | A hole written `_` or `_foo` in the user-inputed source, which we 92 | -- can fill in with candidates. 93 | data Hole = Hole 94 | { holeRealSrcSpan :: !RealSrcSpan 95 | , holeName :: !OccName 96 | , holeType :: !Type 97 | , holeDf :: !DynFlags 98 | , holeDeclaration :: !Declaration 99 | } 100 | 101 | instance Show Hole where 102 | showsPrec p (Hole realSrcSpan name ty df _) = 103 | showString "Hole {holeRealSrcSpan = " . 104 | showsPrec (p + 1) realSrcSpan . 105 | showString ", holeName = " . gshows name . showString ", holeType = " . 106 | showString (showPpr df ty) . showString "}" 107 | 108 | -- | Substition of a source span in the source code with a new string. 109 | data Substitution = Substitution 110 | { substitutionReplacement :: !Name 111 | , substitutionString :: !String 112 | , substitutionType :: !Type 113 | } 114 | 115 | instance Show Substitution where 116 | showsPrec _p (Substitution name _q _ty) = 117 | showString "Substitution {substitutionReplacement = " . 118 | gshows name . showString "}" 119 | 120 | -------------------------------------------------------------------------------- 121 | -- Top-level API 122 | 123 | -- | Get a module which can be completed. Cannot contain type errors, 124 | -- including deferred ones. 125 | getCompletableModule :: GhcMonad m => ModSummary -> m CompletableModule 126 | getCompletableModule ms = 127 | fmap CompletableModule (parseModule ms >>= typecheckModuleNoDeferring) 128 | 129 | -- | Find a declaration by line number. If the line is within a 130 | -- declaration in the module, return that declaration. 131 | declarationByLine :: CompletableModule -> LineNumber -> Maybe Declaration 132 | declarationByLine (CompletableModule typecheckedModule) (LineNumber line) = do 133 | renamedModule <- tm_renamed_source typecheckedModule 134 | let binds = renamedSourceToBag renamedModule 135 | located <- find ((`realSpans` (line, 1)) . getLoc) (bagToList binds) 136 | realSrcSpan <- getRealSrcSpan (getLoc located) 137 | pure 138 | (Declaration 139 | { declarationBind = unLoc located 140 | , declarationRealSrcSpan = realSrcSpan 141 | , declarationRenamedModule = renamedModule 142 | , declarationParsedModule = tm_parsed_module typecheckedModule 143 | , declarationTypecheckedModule = tm_typechecked_source typecheckedModule 144 | , declarationModuleInfo = tm_checked_module_info typecheckedModule 145 | , declarationGlobalRdrEnv = tcg_rdr_env (fst (tm_internals_ typecheckedModule)) 146 | }) 147 | 148 | -- | Get all the holes in the given declaration. 149 | declarationHoles :: DynFlags -> Declaration -> [Hole] 150 | declarationHoles df declaration = go declaration 151 | where 152 | go = 153 | mapMaybe 154 | (\h -> do 155 | (name, src) <- getHoleName h 156 | case listToMaybe 157 | (listify 158 | (isJust . typeAt src) 159 | (declarationTypecheckedModule declaration)) >>= 160 | typeAt src of 161 | Nothing -> Nothing 162 | Just typ -> 163 | pure 164 | (Hole 165 | { holeRealSrcSpan = src 166 | , holeName = name 167 | , holeType = typ 168 | , holeDf = df 169 | , holeDeclaration = declaration 170 | })) . 171 | listify (isJust . getHoleName) . declarationBind 172 | typeAt :: RealSrcSpan -> LHsExpr StageReaderId -> Maybe Type 173 | typeAt rs expr = 174 | if getLoc expr == RealSrcSpan rs 175 | then case expr of 176 | #if __GLASGOW_HASKELL__ >= 806 177 | L _ (HsVar _ (L _ i)) -> pure (idType i) 178 | #else 179 | L _ (HsVar (L _ i)) -> pure (idType i) 180 | #endif 181 | _ -> Nothing 182 | else Nothing 183 | getHoleName :: LHsExpr StageReaderName -> Maybe (OccName, RealSrcSpan) 184 | getHoleName = 185 | \case 186 | #if __GLASGOW_HASKELL__ >= 806 187 | L someSpan (HsUnboundVar _ (TrueExprHole name)) -> do 188 | #else 189 | L someSpan (HsUnboundVar (TrueExprHole name)) -> do 190 | #endif 191 | rs <- getRealSrcSpan someSpan 192 | pure (name, rs) 193 | _ -> Nothing 194 | 195 | -- | Get completions for a declaration. 196 | holeSubstitutions :: GhcMonad m => Hole -> m [Substitution] 197 | holeSubstitutions hole = 198 | do let names = 199 | filter 200 | isValName 201 | (fromMaybe 202 | [] 203 | (modInfoTopLevelScope (declarationModuleInfo declaration))) 204 | hscEnv <- getSession 205 | typedNames <- 206 | liftIO 207 | (foldM 208 | (\(!names') rdrName -> do 209 | (_, ty) <- 210 | tcRnExpr 211 | hscEnv 212 | TM_Inst 213 | (rdrNameToLHsExpr (nameRdrName rdrName)) 214 | pure (maybe names' (: names') (fmap (rdrName, ) ty))) 215 | [] 216 | names) 217 | subs <- 218 | getWellTypedFills 219 | (declarationParsedModule declaration) 220 | hole 221 | typedNames 222 | pure 223 | (sortBy 224 | (flip (comparing (typeSpecificity . substitutionType))) 225 | (map 226 | (\(name, ty, _) -> 227 | Substitution 228 | { substitutionReplacement = name 229 | , substitutionType = ty 230 | , substitutionString = 231 | makeReplacementString 232 | (declarationGlobalRdrEnv declaration) 233 | name 234 | }) 235 | subs)) 236 | where 237 | declaration = holeDeclaration hole 238 | 239 | -- | A vague weighting for relevance of types. We assume that more 240 | -- specific types are more appropriate. 241 | typeSpecificity :: Type -> Int 242 | typeSpecificity t = sum (map rate (listify ((> 0) . rate) t)) 243 | where 244 | rate = 245 | \case 246 | TyConApp {} -> 10 247 | LitTy {} -> 5 248 | FunTy {} -> 1 249 | _ -> 0 250 | 251 | -- | Make a string, qualified if necessary. 252 | makeReplacementString :: GlobalRdrEnv -> Name -> String 253 | makeReplacementString gre name = 254 | case lookupGRE_Name gre name of 255 | Nothing -> unqualified 256 | Just grelt -> 257 | if greltUnqualified grelt && unambiguous grelt 258 | then unqualified 259 | else maybe unqualified qualified (greltQualification grelt) 260 | where 261 | unqualified = occNameString (nameOccName name) 262 | qualified m = moduleNameString m ++ "." ++ unqualified 263 | unambiguous grelt = null conflicts 264 | where 265 | conflicts = 266 | filter 267 | greltUnqualified 268 | (filter 269 | (/= grelt) 270 | (lookupGlobalRdrEnv gre (nameOccName (gre_name grelt)))) 271 | 272 | -- | First the first available qualification for a name. 273 | greltQualification :: GlobalRdrElt -> Maybe ModuleName 274 | greltQualification grelt = 275 | case gre_imp grelt of 276 | (ImpSpec (ImpDeclSpec {is_as = m}) _:_) -> Just m 277 | _ -> Nothing 278 | 279 | -- | The element is not qualified. 280 | greltUnqualified :: GlobalRdrElt -> Bool 281 | greltUnqualified grelt = local || importedUnqualified 282 | where 283 | local = gre_lcl grelt 284 | importedUnqualified = any unQualSpecOK (gre_imp grelt) 285 | 286 | -------------------------------------------------------------------------------- 287 | -- Testing out completions 288 | 289 | data StringEquality = StringEquality 290 | { _stringEqualityDf :: DynFlags 291 | , _stringEqualityType :: Type 292 | } 293 | instance Show StringEquality where 294 | show (StringEquality df x) = showPpr df x 295 | instance Eq StringEquality where 296 | StringEquality df t1 == StringEquality df' t2 = 297 | showPpr df t1 == showPpr df' t2 298 | instance Ord StringEquality where 299 | compare (StringEquality df t1) (StringEquality df' t2) = 300 | compare (showPpr df t1) (showPpr df' t2) 301 | 302 | -- | Get a set of well-typed fills for the given hole. 303 | -- 304 | -- Candidates with the same type are cached, to avoid recompiling the 305 | -- module more than neccessary. 306 | getWellTypedFills :: 307 | GhcMonad m 308 | => ParsedModule 309 | -> Hole 310 | -> [(Name, Type)] 311 | -> m [(Name, Type, ParsedModule)] 312 | getWellTypedFills pm hole names = do 313 | df <- getSessionDynFlags 314 | let hty = normalize df (holeType hole) 315 | fmap 316 | snd 317 | (foldM 318 | (\(!cache, !candidates) (!rdrname, !typ) -> 319 | (do mparsedModule <- 320 | case M.lookup (StringEquality df typ) cache of 321 | Just mparsedModule -> pure mparsedModule 322 | Nothing -> 323 | tryWellTypedFill pm hole (rdrNameToHsExpr (nameRdrName rdrname)) 324 | let !cache' = M.insert (StringEquality df typ) mparsedModule cache 325 | !candidates' = 326 | case mparsedModule of 327 | Nothing -> candidates 328 | Just parsedModule -> (rdrname, typ, parsedModule) : candidates 329 | pure (cache', candidates'))) 330 | (mempty, []) 331 | (filter (\(name, ty) -> unifies' df hty (normalize df ty) name) names)) 332 | 333 | unifies' :: DynFlags -> Type -> Type -> Name -> Bool 334 | unifies' df x y _name = 335 | -- trace 336 | -- ("Unifies? " ++ 337 | -- showPpr df name ++ 338 | -- " :: " ++ 339 | -- showPpr df y ++ 340 | -- "\n " ++ 341 | -- show (T df x) ++ 342 | -- "\n against\n " ++ show (T df y) ++ "\n => " ++ show (unifies df x y)) 343 | (unifies df x y) 344 | 345 | -- | The purpose of this function is to eliminate types that should 346 | -- not be tested with a full module type-check. This checker is 347 | -- stricter than GHC's own unifier, much stricter than Hoogle; it 348 | -- produces false negatives. But it should not produce false positives 349 | -- ideally. 350 | unifies :: DynFlags -> Type -> Type -> Bool 351 | unifies _df t1 t2 = theirs t1 t2 && ours t1 t2 352 | where 353 | theirs x y = 354 | -- trace 355 | -- ("theirs(" ++ 356 | -- showPpr df x ++ 357 | -- "," ++ showPpr df y ++ ")=>" ++ show (isJust (tcUnifyTyKi x y))) 358 | (isJust (tcUnifyTyKi x y)) 359 | -- Let them deal with lits: 360 | ours x@LitTy {} y@LitTy {} = theirs x y 361 | -- We assume a type variable unifies with anything, leave it to 362 | -- them: 363 | ours x@TyVarTy {} y = theirs x y 364 | ours x y@TyVarTy {} = theirs x y 365 | -- We ignore forall's: 366 | ours (ForAllTy _ x) y = ours x y 367 | ours x (ForAllTy _ y) = ours x y 368 | -- We ignore casts: 369 | ours (CastTy x _) y = ours x y 370 | ours x (CastTy y _) = ours x y 371 | -- We assume they know what to do with a coercion: 372 | ours x y@CoercionTy {} = theirs x y 373 | ours x@CoercionTy {} y = theirs x y 374 | -- We only let functions unify with functions, and apps unify with apps: 375 | ours (FunTy x y) (FunTy x' y') = ours x x' && ours y y' 376 | ours (AppTy f x) (AppTy f' x') = ours f f' && ours x x' 377 | -- We let them deal with this: 378 | ours x@TyConApp {} y@TyConApp {} = theirs x y 379 | -- These three should unify, so we let them deal with it: 380 | ours x@AppTy {} y@TyConApp {} = theirs x y 381 | ours y@TyConApp {} x@AppTy {} = theirs x y 382 | -- The rest SHOULD NOT be allowed to unify, because it's too 383 | -- general to produce DWIM results: 384 | ours FunTy {} _ = False 385 | ours _ FunTy {} = False 386 | ours AppTy {} _ = False 387 | ours _ AppTy {} = False 388 | ours TyConApp {} _ = False 389 | ours _ TyConApp {} = False 390 | 391 | isAny :: DynFlags -> Type -> Bool 392 | isAny df t = showPpr df t == "Any" 393 | 394 | data T = T DynFlags Type 395 | instance Show T where 396 | showsPrec p (T df ty0) = 397 | case ty0 of 398 | TyVarTy v -> 399 | showString "(TyVarTy " . showString (showPpr df v) . showString ")" 400 | AppTy t1 t2 -> 401 | showString "(AppTy " . 402 | showsPrec (p + 1) (T df t1) . 403 | showString " " . showsPrec (p + 1) (T df t2) . showString ")" 404 | TyConApp tyCon tys -> 405 | showString "(TyConApp " . 406 | showString (showPpr df tyCon) . 407 | showString " " . showsPrec (p + 1) (map (T df) tys) . showString ")" 408 | ForAllTy _tyvar ty -> 409 | showString "(ForAllTy _ " . showsPrec (p + 1) (T df ty) . showString ")" 410 | FunTy x y -> 411 | showString "(FunTy " . 412 | showsPrec p (T df x) . 413 | showString " " . showsPrec p (T df y) . showString ")" 414 | LitTy litTy -> 415 | showString "(LitTy " . showString (showPpr df litTy) . showString ")" 416 | CastTy ty _k -> 417 | showString "(CastTy " . showsPrec (p + 1) (T df ty) . showString " _)" 418 | CoercionTy _ -> showString "(Coercion _)" 419 | 420 | -- | Strip out weird things from GHC's type system. 421 | normalize :: DynFlags -> Type -> Type 422 | normalize df t0 = evalState (go t0) 1 423 | where 424 | go = 425 | \case 426 | t@TyConApp {} 427 | | isAny df t -> do 428 | u <- get 429 | modify (+ 1) 430 | pure (makeTypeVariable u "was_Any") 431 | FunTy (TyConApp (ghc_tyConFlavour -> "class") _) x -> go x 432 | ForAllTy _ x -> go x 433 | CastTy x _ -> go x 434 | FunTy x y -> FunTy <$> (go x) <*> (go y) 435 | AppTy x y -> AppTy <$> (go x) <*> (go y) 436 | TyConApp tycon xs -> TyConApp <$> pure tycon <*> (mapM go xs) 437 | t@TyVarTy {} -> pure t 438 | t@LitTy {} -> pure t 439 | t@CoercionTy {} -> pure t 440 | 441 | -- | Make a type variable. I have no idea how to create a truly unique 442 | -- name. This is bothersome. 443 | makeTypeVariable :: Int -> String -> Type 444 | makeTypeVariable u n = TyVarTy (mkTyVar name liftedTypeKind) 445 | where 446 | name = 447 | mkInternalName (mkUnique 'Z' u) (mkOccName OccName.varName n) noSrcSpan 448 | 449 | -- | Try to fill a hole with the given expression; if it type-checks, 450 | -- we return the newly updated parse tree. Otherwise, we return Nothing. 451 | tryWellTypedFill :: 452 | GhcMonad m 453 | => ParsedModule 454 | -> Hole 455 | -> HsExpr StageReaderRdrName 456 | -> m (Maybe ParsedModule) 457 | tryWellTypedFill pm hole expr = 458 | handleSourceError 459 | (const (pure Nothing)) 460 | (fmap 461 | (Just . tm_parsed_module) 462 | (typecheckModuleNoDeferring (fillHole pm hole expr))) 463 | 464 | -------------------------------------------------------------------------------- 465 | -- Filling holes in the AST 466 | 467 | -- | Fill the given hole in the module with the given expression. 468 | fillHole :: ParsedModule -> Hole -> HsExpr StageReaderRdrName -> ParsedModule 469 | fillHole pm hole expr = 470 | pm {pm_parsed_source = everywhere (mkT replace) (pm_parsed_source pm)} 471 | where 472 | replace :: LHsExpr StageReaderRdrName -> LHsExpr StageReaderRdrName 473 | replace = 474 | (\case 475 | L someSpan _ 476 | | Just realSrcSpan <- getRealSrcSpan someSpan 477 | , realSrcSpan == holeRealSrcSpan hole -> L someSpan expr 478 | e -> e) 479 | 480 | -------------------------------------------------------------------------------- 481 | -- Helpers 482 | 483 | rdrNameToLHsExpr :: RdrName -> GenLocated SrcSpan (HsExpr StageReaderRdrName) 484 | rdrNameToLHsExpr rdrname = 485 | L (UnhelpfulSpan (mkFastString "Generated by rdrNameToLHsExpr")) 486 | #if __GLASGOW_HASKELL__ >= 806 487 | (HsVar NoExt 488 | #else 489 | (HsVar 490 | #endif 491 | (L (UnhelpfulSpan (mkFastString "Generated by getWellTypedFills")) 492 | rdrname)) 493 | 494 | rdrNameToHsExpr :: RdrName -> HsExpr StageReaderRdrName 495 | rdrNameToHsExpr rdrname = 496 | #if __GLASGOW_HASKELL__ >= 806 497 | HsVar NoExt 498 | #else 499 | HsVar 500 | #endif 501 | (L (UnhelpfulSpan (mkFastString "Generated by rdrNameToHsExpr")) rdrname) 502 | 503 | -- | Type-check the module without deferring type errors, and without 504 | -- logging messages. 505 | typecheckModuleNoDeferring :: GhcMonad m => ParsedModule -> m TypecheckedModule 506 | typecheckModuleNoDeferring parsed = do 507 | typecheckModule 508 | parsed 509 | { GHC.pm_mod_summary = 510 | (GHC.pm_mod_summary parsed) 511 | { HscTypes.ms_hspp_opts = 512 | unSetGeneralFlag' 513 | Opt_DeferTypeErrors 514 | (HscTypes.ms_hspp_opts (GHC.pm_mod_summary parsed)) 515 | {log_action = nullLogAction} 516 | } 517 | } 518 | where 519 | nullLogAction _df _reason _sev _span _style _msgdoc = pure () 520 | 521 | -- | Convert parsed source groups into one bag of binds. 522 | _parsedModuleToBag :: ParsedModule -> Bag (LHsBindLR StageReaderRdrName StageReaderRdrName) 523 | _parsedModuleToBag = 524 | listToBag . mapMaybe valD . hsmodDecls . unLoc . pm_parsed_source 525 | where 526 | valD = 527 | \case 528 | #if __GLASGOW_HASKELL__ >= 806 529 | L l (ValD _ hsBind) -> pure (L l hsBind) 530 | #else 531 | L l (ValD hsBind) -> pure (L l hsBind) 532 | #endif 533 | _ -> Nothing 534 | 535 | -- | Convert renamed source groups into one bag of binds. 536 | renamedSourceToBag :: RenamedSource -> Bag (LHsBindLR StageReaderName StageReaderName) 537 | renamedSourceToBag (hsGroup, _, _, _) = unHsValBindsLR (hs_valds hsGroup) 538 | where 539 | unHsValBindsLR = 540 | \case 541 | #if __GLASGOW_HASKELL__ >= 806 542 | ValBinds _ binds _ -> binds 543 | XValBindsLR (NValBinds pairs _) -> unionManyBags (map snd pairs) 544 | #else 545 | ValBindsIn binds _ -> binds 546 | ValBindsOut pairs _ -> unionManyBags (map snd pairs) 547 | #endif 548 | 549 | -- | Does X span over the point Y? 550 | realSpans :: SrcSpan -> (Int, Int) -> Bool 551 | realSpans x y = 552 | fromMaybe 553 | False 554 | (do _ <- getRealSrcSpan x 555 | pure (spans x y)) 556 | 557 | -- | Try to get a real span. 558 | getRealSrcSpan :: SrcSpan -> Maybe RealSrcSpan 559 | getRealSrcSpan = 560 | \case 561 | RealSrcSpan r -> pure r 562 | _ -> Nothing 563 | -------------------------------------------------------------------------------- /src/GhciFind.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | {-# LANGUAGE NondecreasingIndentation #-} 3 | {-# LANGUAGE CPP #-} 4 | {-# LANGUAGE BangPatterns #-} 5 | 6 | -- | Find type/location information. 7 | 8 | module GhciFind 9 | (findType,FindType(..),findLoc,findNameUses,findCompletions,guessModule) 10 | where 11 | 12 | import Intero.Compat 13 | #if __GLASGOW_HASKELL__ >= 800 14 | import Module 15 | #endif 16 | import Control.Exception 17 | #if __GLASGOW_HASKELL__ < 710 18 | import Data.Foldable (foldMap) 19 | #endif 20 | import Data.List 21 | import Data.Map (Map) 22 | import qualified Data.Map as M 23 | import Data.Maybe 24 | import DynFlags 25 | import FastString 26 | import GHC 27 | import GhcMonad 28 | import GhciInfo (showppr) 29 | import GhciTypes 30 | import Name 31 | import SrcLoc 32 | import System.Directory 33 | import Var 34 | 35 | -- | Check if there is are imported modules that should be searched 36 | -- for the completion sample string. If so, returns the name qualifier 37 | -- (i.e. module name or alias), the identifier prefix to search for, 38 | -- and the `ModuleName`s of the modules in which to search. 39 | findQualifiedSource :: [ImportDecl n] -> String 40 | -> Maybe (String, String, [ModuleName]) 41 | findQualifiedSource importDecls sample = 42 | do (ident,qual) <- breakQual sample 43 | mnames <- (\nms -> if null nms then Nothing else Just nms) 44 | (foldMap (maybeToList . knownAs qual) importDecls) 45 | return (qual++".", ident, mnames) 46 | where breakQual xs = case break (== '.') (reverse xs) of 47 | (h,_:t) -> Just (reverse h, reverse t) 48 | _ -> Nothing 49 | knownAs qual m 50 | | qual == moduleNameString name || maybe False (qual ==) (asName m) = 51 | Just name 52 | | otherwise = Nothing 53 | where name = unLoc (ideclName m) 54 | #if __GLASGOW_HASKELL__ >= 802 55 | asName = fmap (moduleNameString . unLoc) . ideclAs 56 | #else 57 | asName = fmap moduleNameString . ideclAs 58 | #endif 59 | 60 | -- | Find completions for the sample, context given by the location. 61 | findCompletions :: (GhcMonad m) 62 | => Map ModuleName ModInfo 63 | -> FilePath 64 | -> String 65 | -> Int 66 | -> Int 67 | -> Int 68 | -> Int 69 | -> m (Either String [String]) 70 | findCompletions infos fp sample sl sc el ec = 71 | do mname <- guessModule infos fp 72 | case mname of 73 | Nothing -> 74 | return (Left "Couldn't guess that module name. Does it exist?") 75 | Just name -> 76 | case M.lookup name infos of 77 | Nothing -> 78 | return (Left ("No module info for the current file! Try loading it?")) 79 | Just moduleInf -> 80 | do df <- getDynFlags 81 | (qual, ident, minfs) <- 82 | let noQual = ("", sample, [modinfoInfo moduleInf]) 83 | getModInfo qmname = 84 | findModule qmname Nothing >>= getModuleInfo 85 | in if '.' `elem` sample 86 | then case findQualifiedSource 87 | (map unLoc (modinfoImports moduleInf)) 88 | sample of 89 | Just (qual, ident, qualModNames) -> do 90 | minfos <- fmap catMaybes 91 | (mapM getModInfo qualModNames) 92 | if null minfos 93 | then return noQual 94 | else return (qual, ident, minfos) 95 | Nothing -> return noQual 96 | else return noQual 97 | let toplevelNames = concat (mapMaybe modInfoTopLevelScope minfs) 98 | filteredToplevels = 99 | map (qual ++) 100 | (filter (isPrefixOf ident) 101 | (map (showppr df) toplevelNames)) 102 | localNames <- findLocalizedCompletions (modinfoSpans moduleInf) 103 | sample sl sc el ec 104 | return (Right (take 30 (nub (localNames ++ filteredToplevels)))) 105 | 106 | -- | Find completions within the local scope of a definition of a 107 | -- module. 108 | findLocalizedCompletions 109 | :: GhcMonad m 110 | => [SpanInfo] 111 | -> String 112 | -> Int 113 | -> Int 114 | -> Int 115 | -> Int 116 | -> m [String] 117 | findLocalizedCompletions spans' prefix _sl _sc _el _ec = 118 | do df <- getDynFlags 119 | return (mapMaybe (complete df) spans') 120 | where complete 121 | :: DynFlags -> SpanInfo -> Maybe String 122 | complete df si = 123 | do var <- spaninfoVar si 124 | let str = showppr df var 125 | if isPrefixOf prefix str 126 | then case getSrcLoc (getName var) of 127 | RealSrcLoc {} -> Just str 128 | -- Probably an internally generated name. Ignore it: 129 | -- See here: https://github.com/chrisdone/intero/issues/531 130 | -- We ignore defered-scope-error names like foo_a8s76 131 | UnhelpfulLoc {} -> Nothing 132 | else Nothing 133 | 134 | -- | Find any uses of the given identifier in the codebase. 135 | findNameUses :: (GhcMonad m) 136 | => Map ModuleName ModInfo 137 | -> FilePath 138 | -> String 139 | -> Int 140 | -> Int 141 | -> Int 142 | -> Int 143 | -> m (Either String [SrcSpan]) 144 | findNameUses infos fp string sl sc el ec = 145 | do mname <- guessModule infos fp 146 | case mname of 147 | Nothing -> 148 | return (Left "Couldn't guess that module name. Does it exist?") 149 | Just name -> 150 | case M.lookup name infos of 151 | Nothing -> 152 | return (Left ("No module info for the current file! Try loading it?")) 153 | Just info -> 154 | do mname' <- findName infos info string sl sc el ec 155 | case mname' of 156 | Left e -> return (Left e) 157 | Right name' -> 158 | case getSrcSpan name' of 159 | UnhelpfulSpan{} -> 160 | do d <- getSessionDynFlags 161 | return (Left ("Found a name, but no location information. The module is: " ++ 162 | maybe "" 163 | (showppr d . moduleName) 164 | (nameModule_maybe name'))) 165 | span' -> 166 | return (Right (stripSurrounding 167 | (span' : 168 | map makeSrcSpan 169 | (filter (fromMaybe False . 170 | fmap (reliableNameEquality name') . 171 | fmap getName . 172 | spaninfoVar) 173 | (modinfoSpans info))))) 174 | where makeSrcSpan (SpanInfo sl' sc' el' ec' _ _) = 175 | RealSrcSpan 176 | (mkRealSrcSpan 177 | (mkRealSrcLoc (mkFastString fp) 178 | sl' 179 | (1 + sc')) 180 | (mkRealSrcLoc (mkFastString fp) 181 | el' 182 | (1 + ec'))) 183 | 184 | -- | Reliable equality for two names. This tests based on the start 185 | -- line and start column and module. 186 | -- 187 | -- We don't use standard equality. The unique can differ. Even the end 188 | -- column can differ. 189 | reliableNameEquality :: Name -> Name -> Bool 190 | reliableNameEquality name1 name2 = nameSrcLoc name1 == nameSrcLoc name2 191 | 192 | -- | Strip out spans which surrounding other spans in a parent->child 193 | -- fashion. Those are useless. 194 | stripSurrounding :: [SrcSpan] -> [SrcSpan] 195 | stripSurrounding xs = 196 | mapMaybe (\x -> if any (\y -> overlaps x y && x /= y) xs 197 | then Nothing 198 | else Just x) 199 | xs 200 | 201 | -- | Does x overlap y in x `overlaps` y? 202 | overlaps :: SrcSpan -> SrcSpan -> Bool 203 | overlaps y x = 204 | case (x,y) of 205 | (RealSrcSpan x',RealSrcSpan y') -> 206 | realSrcSpanStart y' <= realSrcSpanStart x' && 207 | realSrcSpanEnd y' >= realSrcSpanEnd x' 208 | _ -> False 209 | 210 | -- | Try to find the location of the given identifier at the given 211 | -- position in the module. 212 | findLoc :: (GhcMonad m) 213 | => Map ModuleName ModInfo 214 | -> FilePath 215 | -> String 216 | -> Int 217 | -> Int 218 | -> Int 219 | -> Int 220 | -> m (Either String SrcSpan) 221 | findLoc infos fp string sl sc el ec = 222 | do mname <- guessModule infos fp 223 | case mname of 224 | Nothing -> 225 | return (Left "Couldn't guess that module name. Does it exist?") 226 | Just name -> 227 | case M.lookup name infos of 228 | Nothing -> 229 | return (Left ("No module info for the current file! Try loading it?")) 230 | Just info -> 231 | case findImportLoc infos info sl sc el ec of 232 | Just result -> return (Right result) 233 | Nothing -> 234 | do mname' <- findName infos info string sl sc el ec 235 | d <- getSessionDynFlags 236 | case mname' of 237 | Left reason -> 238 | return (Left reason) 239 | Right name' -> 240 | case getSrcSpan name' of 241 | UnhelpfulSpan{} -> 242 | return (Left ("Found a name, but no location information. The module is: " ++ 243 | maybe "" 244 | (showppr d . moduleName) 245 | (nameModule_maybe name'))) 246 | span' -> 247 | return (Right span') 248 | 249 | findImportLoc :: (Map ModuleName ModInfo) -> ModInfo -> Int -> Int -> Int -> Int -> Maybe SrcSpan 250 | findImportLoc infos info sl sc el ec = 251 | do importedModuleName <- getModuleImportedAt info sl sc el ec 252 | importedModInfo <- M.lookup importedModuleName infos 253 | return (modinfoLocation importedModInfo) 254 | 255 | getModuleImportedAt :: ModInfo -> Int -> Int -> Int -> Int -> Maybe ModuleName 256 | getModuleImportedAt info sl sc el ec = fmap (unLoc . ideclName . unLoc) importDeclarationMaybe 257 | where importDeclarationMaybe = listToMaybe $ filter isWithinRange (modinfoImports info) 258 | isWithinRange importDecl = containsSrcSpan sl sc el ec (getLoc $ ideclName $ unLoc importDecl) 259 | 260 | -- | Try to resolve the name located at the given position, or 261 | -- otherwise resolve based on the current module's scope. 262 | findName :: GhcMonad m 263 | => Map ModuleName ModInfo 264 | -> ModInfo 265 | -> String 266 | -> Int 267 | -> Int 268 | -> Int 269 | -> Int 270 | -> m (Either String Name) 271 | findName infos mi string sl sc el ec = 272 | case resolveName (modinfoSpans mi) 273 | sl 274 | sc 275 | el 276 | ec of 277 | Nothing -> tryExternalModuleResolution 278 | Just name -> 279 | case getSrcSpan name of 280 | UnhelpfulSpan{} -> tryExternalModuleResolution 281 | _ -> return (Right (getName name)) 282 | where tryExternalModuleResolution = 283 | case find (matchName string) 284 | (fromMaybe [] (modInfoTopLevelScope (modinfoInfo mi))) of 285 | Nothing -> 286 | return (Left "Couldn't resolve to any modules.") 287 | Just imported -> resolveNameFromModule infos imported 288 | matchName :: String -> Name -> Bool 289 | matchName str name = 290 | str == 291 | occNameString (getOccName name) 292 | 293 | -- | Try to resolve the name from another (loaded) module's exports. 294 | resolveNameFromModule :: GhcMonad m 295 | => Map ModuleName ModInfo 296 | -> Name 297 | -> m (Either String Name) 298 | resolveNameFromModule infos name = 299 | do d <- getSessionDynFlags 300 | case nameModule_maybe name of 301 | Nothing -> 302 | return (Left ("No module for " ++ 303 | showppr d name)) 304 | Just modL -> 305 | do case M.lookup (moduleName modL) infos of 306 | Nothing -> 307 | #if __GLASGOW_HASKELL__ >= 800 308 | do (return (Left (unitIdString (moduleUnitId modL) ++ ":" ++ 309 | #elif __GLASGOW_HASKELL__ >= 709 310 | do (return (Left (showppr d (modulePackageKey modL) ++ ":" ++ 311 | #else 312 | do (return (Left (showppr d (modulePackageId modL) ++ ":" ++ 313 | #endif 314 | showppr d modL))) 315 | Just info -> 316 | case find (reliableNameEquality name) 317 | (modInfoExports (modinfoInfo info)) of 318 | Just name' -> 319 | return (Right name') 320 | Nothing -> 321 | case find (reliableNameEquality name) 322 | (fromMaybe [] (modInfoTopLevelScope (modinfoInfo info))) of 323 | Just name' -> 324 | return (Right name') 325 | Nothing -> do 326 | result <- lookupGlobalName name 327 | case result of 328 | Nothing -> 329 | return (Left ("No matching export in any local modules: " ++ showppr d name)) 330 | Just tyThing -> 331 | return (Right (getName tyThing)) 332 | 333 | -- | Try to resolve the type display from the given span. 334 | resolveName :: [SpanInfo] -> Int -> Int -> Int -> Int -> Maybe Var 335 | resolveName spans' sl sc el ec = 336 | listToMaybe (mapMaybe spaninfoVar (filter inside (reverse spans'))) 337 | where inside (SpanInfo sl' sc' el' ec' _ _) = 338 | ((sl' == sl && sc' >= sc) || (sl' > sl)) && 339 | ((el' == el && ec' <= ec) || (el' < el)) 340 | 341 | data FindType 342 | = FindTypeFail String 343 | | FindType ModInfo 344 | Type 345 | | FindTyThing ModInfo 346 | TyThing 347 | 348 | -- | Try to find the type of the given span. 349 | findType :: GhcMonad m 350 | => Map ModuleName ModInfo 351 | -> FilePath 352 | -> String 353 | -> Int 354 | -> Int 355 | -> Int 356 | -> Int 357 | -> m FindType 358 | findType infos fp string sl sc el ec = 359 | do mname <- guessModule infos fp 360 | case mname of 361 | Nothing -> 362 | return (FindTypeFail "Couldn't guess that module name. Does it exist?") 363 | Just modName -> 364 | case M.lookup modName infos of 365 | Nothing -> 366 | return (FindTypeFail "Couldn't guess the module name. Is this module loaded?") 367 | Just minfo -> 368 | do names <- lookupNamesInContext string 369 | let !mspaninfo = 370 | resolveSpanInfo (modinfoSpans minfo) 371 | sl 372 | sc 373 | el 374 | ec 375 | case mspaninfo of 376 | Just si 377 | | Just ty <- spaninfoType si -> 378 | case fmap Var.varName (spaninfoVar si) of 379 | Nothing -> return (FindType minfo ty) 380 | Just name -> 381 | case find (reliableNameEquality name) names of 382 | Just nameWithBetterType -> 383 | do result <- ghc_getInfo True nameWithBetterType 384 | case result of 385 | Just (thing,_,_,_) -> 386 | return (FindTyThing minfo thing) 387 | Nothing -> return (FindType minfo ty) 388 | Nothing -> return (FindType minfo ty) 389 | _ -> 390 | fmap (FindType minfo) 391 | #if __GLASGOW_HASKELL__ >= 802 392 | (exprType TM_Inst string) 393 | #else 394 | (exprType string) 395 | #endif 396 | 397 | -- | Try to resolve the type display from the given span. 398 | resolveSpanInfo :: [SpanInfo] -> Int -> Int -> Int -> Int -> Maybe SpanInfo 399 | resolveSpanInfo spanList spanSL spanSC spanEL spanEC = 400 | listToMaybe 401 | (sortBy (flip compareSpanInfoStart) 402 | (filter (containsSpanInfo spanSL spanSC spanEL spanEC) spanList)) 403 | 404 | -- | Compare the start of two span infos. 405 | compareSpanInfoStart :: SpanInfo -> SpanInfo -> Ordering 406 | compareSpanInfoStart this that = 407 | case compare (spaninfoStartLine this) (spaninfoStartLine that) of 408 | EQ -> compare (spaninfoStartCol this) (spaninfoStartCol that) 409 | c -> c 410 | 411 | -- | Does the 'SpanInfo' contain the location given by the Ints? 412 | containsSpanInfo :: Int -> Int -> Int -> Int -> SpanInfo -> Bool 413 | containsSpanInfo spanSL spanSC spanEL spanEC (SpanInfo ancestorSL ancestorSC ancestorEL ancestorEC _ _) = 414 | contains spanSL spanSC spanEL spanEC ancestorSL ancestorSC ancestorEL ancestorEC 415 | 416 | containsSrcSpan :: Int -> Int -> Int -> Int -> SrcSpan -> Bool 417 | containsSrcSpan spanSL spanSC spanEL spanEC (RealSrcSpan spn) = 418 | contains spanSL spanSC spanEL spanEC (srcSpanStartLine spn) (srcSpanStartCol spn - 1) (srcSpanEndLine spn) (srcSpanEndCol spn - 1) 419 | containsSrcSpan _ _ _ _ _ = False 420 | 421 | contains :: Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Bool 422 | contains spanSL spanSC spanEL spanEC ancestorSL ancestorSC ancestorEL ancestorEC = 423 | ((ancestorSL == spanSL && spanSC >= ancestorSC) || (ancestorSL < spanSL)) && 424 | ((ancestorEL == spanEL && spanEC <= ancestorEC) || (ancestorEL > spanEL)) 425 | 426 | -- | Guess a module name from a file path. 427 | guessModule :: GhcMonad m 428 | => Map ModuleName ModInfo -> FilePath -> m (Maybe ModuleName) 429 | guessModule infos fp = 430 | do target <- guessTarget fp Nothing 431 | case targetId target of 432 | TargetModule mn -> return (Just mn) 433 | TargetFile fp' _ -> 434 | case find ((Just fp' ==) . 435 | ml_hs_file . ms_location . modinfoSummary . snd) 436 | (M.toList infos) of 437 | Just (mn,_) -> return (Just mn) 438 | Nothing -> 439 | do fp'' <- liftIO (makeRelativeToCurrentDirectory fp') 440 | target' <- guessTarget fp'' Nothing 441 | case targetId target' of 442 | TargetModule mn -> 443 | return (Just mn) 444 | _ -> 445 | case find ((Just fp'' ==) . 446 | ml_hs_file . ms_location . modinfoSummary . snd) 447 | (M.toList infos) of 448 | Just (mn,_) -> 449 | return (Just mn) 450 | Nothing -> return Nothing 451 | 452 | -- | Lookup the name of something in the current context. 453 | lookupNamesInContext :: GhcMonad m => String -> m [Name] 454 | lookupNamesInContext string = 455 | gcatch (GHC.parseName string) 456 | (\(_ :: SomeException) -> return []) 457 | -------------------------------------------------------------------------------- /src/GhciInfo.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | {-# LANGUAGE RankNTypes #-} 4 | 5 | -- | Get information on modules, identifiers, etc. 6 | 7 | module GhciInfo (collectInfo,getModInfo,showppr) where 8 | 9 | import ConLike 10 | import Control.Exception 11 | import Control.Monad 12 | import qualified CoreUtils 13 | import Data.Data 14 | import qualified Data.Generics 15 | import Data.List 16 | import Data.Map.Strict (Map) 17 | import qualified Data.Map.Strict as M 18 | import Data.Maybe 19 | import Data.Time 20 | import DataCon 21 | import Desugar 22 | import DynFlags 23 | import GHC 24 | import GhcMonad 25 | import GhciTypes 26 | import HscTypes 27 | import Intero.Compat 28 | import Outputable 29 | import Prelude hiding (mod) 30 | import System.Directory 31 | import TcHsSyn 32 | import Var 33 | 34 | #if __GLASGOW_HASKELL__ <= 802 35 | import NameSet 36 | #endif 37 | 38 | #if MIN_VERSION_ghc(7,8,3) 39 | #else 40 | import Bag 41 | #endif 42 | 43 | -- | Collect type info data for the loaded modules. 44 | collectInfo :: (GhcMonad m) 45 | => Map ModuleName ModInfo -> [ModuleName] -> m (Map ModuleName ModInfo) 46 | collectInfo ms loaded = 47 | do df <- getSessionDynFlags 48 | -- Generate for all modules in interpreted mode. 49 | invalidated <- 50 | liftIO (if hscTarget df == HscInterpreted 51 | then return loaded 52 | else filterM cacheInvalid loaded) 53 | if null invalidated 54 | then return ms 55 | else do liftIO (putStrLn ("Collecting type info for " ++ 56 | show (length invalidated) ++ 57 | " module(s) ... ")) 58 | foldM (\m name -> 59 | gcatch (do info <- getModInfo name 60 | return (M.insert name info m)) 61 | (\(e :: SomeException) -> 62 | do liftIO (putStrLn ("Error while getting type info from " ++ 63 | showppr df name ++ 64 | ": " ++ show e)) 65 | return m)) 66 | ms 67 | invalidated 68 | where cacheInvalid name = 69 | case M.lookup name ms of 70 | Nothing -> return True 71 | Just mi -> 72 | do let fp = 73 | #if MIN_VERSION_ghc(8,0,4) 74 | ml_hi_file (ms_location (modinfoSummary mi)) 75 | #else 76 | ml_obj_file (ms_location (modinfoSummary mi)) 77 | #endif 78 | last' = modinfoLastUpdate mi 79 | exists <- doesFileExist fp 80 | if exists 81 | then do mod <- getModificationTime fp 82 | return (mod > last') 83 | else return True 84 | 85 | -- | Get info about the module: summary, types, etc. 86 | getModInfo :: (GhcMonad m) => ModuleName -> m ModInfo 87 | getModInfo name = 88 | do m <- getModSummary name 89 | p <- parseModule m 90 | let location = getModuleLocation (parsedSource p) 91 | typechecked <- typecheckModuleSilent p 92 | let Just (_, imports, _, _) = renamedSource typechecked 93 | allTypes <- processAllTypeCheckedModule typechecked 94 | let i = tm_checked_module_info typechecked 95 | now <- liftIO getCurrentTime 96 | return (ModInfo m allTypes i now imports location) 97 | 98 | -- | Type-check the module without logging messages. 99 | typecheckModuleSilent :: GhcMonad m => ParsedModule -> m TypecheckedModule 100 | #if MIN_VERSION_ghc(8,0,1) 101 | typecheckModuleSilent parsed = do 102 | typecheckModule 103 | parsed 104 | { GHC.pm_mod_summary = 105 | (GHC.pm_mod_summary parsed) 106 | { HscTypes.ms_hspp_opts = 107 | (HscTypes.ms_hspp_opts (GHC.pm_mod_summary parsed)) 108 | {log_action = nullLogAction} 109 | } 110 | } 111 | where 112 | nullLogAction _df _reason _sev _span _style _msgdoc = return () 113 | #else 114 | typecheckModuleSilent parsed = do 115 | typecheckModule 116 | parsed 117 | { GHC.pm_mod_summary = 118 | (GHC.pm_mod_summary parsed) 119 | { HscTypes.ms_hspp_opts = 120 | (HscTypes.ms_hspp_opts (GHC.pm_mod_summary parsed)) 121 | {log_action = nullLogAction} 122 | } 123 | } 124 | where 125 | nullLogAction _df _reason _sev _span _style = return () 126 | #endif 127 | 128 | getModuleLocation :: ParsedSource -> SrcSpan 129 | getModuleLocation pSource = case hsmodName (unLoc pSource) of 130 | Just located -> getLoc located 131 | Nothing -> noSrcSpan 132 | 133 | -- | Get ALL source spans in the module. 134 | processAllTypeCheckedModule :: GhcMonad m 135 | => TypecheckedModule -> m [SpanInfo] 136 | processAllTypeCheckedModule tcm = 137 | do let tcs = tm_typechecked_source tcm 138 | bs = listifyAllSpans tcs :: [LHsBind StageReaderId] 139 | es = listifyAllSpans tcs :: [LHsExpr StageReaderId] 140 | ps = listifyAllSpans tcs :: [LPat StageReaderId] 141 | bts <- mapM (getTypeLHsBind tcm) bs 142 | ets <- mapM (getTypeLHsExpr tcm) es 143 | pts <- mapM (getTypeLPat tcm) ps 144 | return (mapMaybe toSpanInfo (sortBy cmp (concat bts ++ catMaybes (concat [ets,pts])))) 145 | where cmp (_,a,_) (_,b,_) 146 | | a `isSubspanOf` b = LT 147 | | b `isSubspanOf` a = GT 148 | | otherwise = EQ 149 | 150 | getTypeLHsBind :: (GhcMonad m) 151 | => TypecheckedModule 152 | -> LHsBind StageReaderId 153 | -> m [(Maybe Id,SrcSpan,Type)] 154 | #if MIN_VERSION_ghc(7,8,3) 155 | getTypeLHsBind _ (L _spn FunBind{fun_id = pid,fun_matches = MG{}}) = 156 | return (return (Just (unLoc pid),getLoc pid,varType (unLoc pid))) 157 | #else 158 | getTypeLHsBind _ (L _spn FunBind{fun_id = pid,fun_matches = MG _ _ _typ}) = 159 | return (return (Just (unLoc pid),getLoc pid,varType (unLoc pid))) 160 | #endif 161 | #if MIN_VERSION_ghc(7,8,3) 162 | #else 163 | getTypeLHsBind m (L _spn AbsBinds{abs_binds = binds}) = 164 | fmap concat 165 | (mapM (getTypeLHsBind m) 166 | (map snd (bagToList binds))) 167 | #endif 168 | getTypeLHsBind _ _ = return [] 169 | -- getTypeLHsBind _ x = 170 | -- do df <- getSessionDynFlags 171 | -- error ("getTypeLHsBind: unhandled case: " ++ 172 | -- showppr df x) 173 | 174 | getTypeLHsExpr :: (GhcMonad m) 175 | => TypecheckedModule 176 | -> LHsExpr StageReaderId 177 | -> m (Maybe (Maybe Id,SrcSpan,Type)) 178 | getTypeLHsExpr _ e = 179 | do hs_env <- getSession 180 | (_,mbe) <- liftIO (deSugarExpr hs_env e) 181 | case mbe of 182 | Nothing -> return Nothing 183 | Just expr -> 184 | return (Just (case unwrapVar (unLoc e) of 185 | #if __GLASGOW_HASKELL__ >= 806 186 | HsVar _ (L _ i) -> Just i 187 | #elif __GLASGOW_HASKELL__ >= 800 188 | HsVar (L _ i) -> Just i 189 | #else 190 | HsVar i -> Just i 191 | #endif 192 | _ -> Nothing 193 | ,getLoc e 194 | ,CoreUtils.exprType expr)) 195 | where 196 | #if __GLASGOW_HASKELL__ >= 806 197 | unwrapVar (HsWrap _ _ var) = var 198 | #else 199 | unwrapVar (HsWrap _ var) = var 200 | #endif 201 | unwrapVar e' = e' 202 | 203 | -- | Get id and type for patterns. 204 | getTypeLPat :: (GhcMonad m) 205 | => TypecheckedModule -> LPat StageReaderId -> m (Maybe (Maybe Id,SrcSpan,Type)) 206 | getTypeLPat _ (L spn pat) = 207 | return (Just (getMaybeId pat,spn,getPatType pat)) 208 | where 209 | getPatType (ConPatOut (L _ (RealDataCon dc)) _ _ _ _ _ _) = 210 | dataConRepType dc 211 | getPatType pat' = hsPatType pat' 212 | #if __GLASGOW_HASKELL__ >= 806 213 | getMaybeId (VarPat _ (L _ vid)) = Just vid 214 | #elif __GLASGOW_HASKELL__ >= 800 215 | getMaybeId (VarPat (L _ vid)) = Just vid 216 | #else 217 | getMaybeId (VarPat vid) = Just vid 218 | #endif 219 | getMaybeId _ = Nothing 220 | 221 | -- | Get ALL source spans in the source. 222 | listifyAllSpans :: Typeable a 223 | => TypecheckedSource -> [Located a] 224 | listifyAllSpans tcs = 225 | listifyStaged TypeChecker p tcs 226 | where p (L spn _) = isGoodSrcSpan spn 227 | 228 | listifyStaged :: Typeable r 229 | => Stage -> (r -> Bool) -> Data.Generics.GenericQ [r] 230 | #if __GLASGOW_HASKELL__ <= 802 231 | listifyStaged s p = 232 | everythingStaged 233 | s 234 | (++) 235 | [] 236 | ([] `Data.Generics.mkQ` 237 | (\x -> [x | p x])) 238 | #else 239 | listifyStaged _ p = Data.Generics.listify p 240 | #endif 241 | 242 | ------------------------------------------------------------------------------ 243 | -- The following was taken from 'ghc-syb-utils' 244 | -- 245 | -- ghc-syb-utils: 246 | -- https://github.com/nominolo/ghc-syb 247 | 248 | -- | Ghc Ast types tend to have undefined holes, to be filled 249 | -- by later compiler phases. We tag Asts with their source, 250 | -- so that we can avoid such holes based on who generated the Asts. 251 | data Stage 252 | = Parser 253 | | Renamer 254 | | TypeChecker 255 | deriving (Eq,Ord,Show) 256 | 257 | -- | Like 'everything', but avoid known potholes, based on the 'Stage' that 258 | -- generated the Ast. 259 | #if __GLASGOW_HASKELL__ <= 802 260 | everythingStaged :: Stage -> (r -> r -> r) -> r -> Data.Generics.GenericQ r -> Data.Generics.GenericQ r 261 | everythingStaged stage k z f x 262 | | (const False `Data.Generics.extQ` postTcType `Data.Generics.extQ` fixity `Data.Generics.extQ` nameSet) x = z 263 | | otherwise = foldl k (f x) (gmapQ (everythingStaged stage k z f) x) 264 | where nameSet = const (stage `elem` [Parser,TypeChecker]) :: NameSet -> Bool 265 | #if __GLASGOW_HASKELL__ >= 709 266 | postTcType = const (stage Bool 267 | #else 268 | postTcType = const (stage Bool 269 | #endif 270 | fixity = const (stage Bool 271 | #endif 272 | 273 | 274 | -- | Pretty print the types into a 'SpanInfo'. 275 | toSpanInfo :: (Maybe Id,SrcSpan,Type) -> Maybe SpanInfo 276 | toSpanInfo (n,mspan,typ) = 277 | case mspan of 278 | RealSrcSpan spn -> 279 | Just (SpanInfo (srcSpanStartLine spn) 280 | (srcSpanStartCol spn - 1) 281 | (srcSpanEndLine spn) 282 | (srcSpanEndCol spn - 1) 283 | (Just typ) 284 | n) 285 | _ -> Nothing 286 | 287 | -- | Pretty print something to string. 288 | showppr :: Outputable a 289 | => DynFlags -> a -> String 290 | showppr dflags = 291 | showSDocForUser dflags neverQualify . 292 | ppr 293 | -------------------------------------------------------------------------------- /src/GhciMonad.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE UnboxedTuples #-} 2 | {-# LANGUAGE MagicHash #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE CPP #-} 5 | {-# OPTIONS_GHC -fno-cse -fno-warn-orphans -fno-warn-warnings-deprecations #-} 6 | -- -fno-cse is needed for GLOBAL_VAR's to behave properly 7 | 8 | ----------------------------------------------------------------------------- 9 | -- 10 | -- Monadery code used in InteractiveUI 11 | -- 12 | -- (c) The GHC Team 2005-2006 13 | -- 14 | ----------------------------------------------------------------------------- 15 | 16 | module GhciMonad ( 17 | GHCi(..), startGHCi, 18 | GHCiState(..), setGHCiState, getGHCiState, modifyGHCiState, 19 | GHCiOption(..), isOptionSet, setOption, unsetOption, 20 | Command, 21 | BreakLocation(..), 22 | TickArray, 23 | getDynFlags, 24 | reifyGHCi,reflectGHCi, 25 | 26 | runStmt, runDecls, resume, timeIt, recordBreak, revertCAFs, 27 | printForUserNeverQualify, printForUserModInfo, 28 | 29 | printForUser, printForUserPartWay, prettyLocations, 30 | initInterpBuffering, turnOffBuffering, flushInterpBuffers, 31 | ) where 32 | 33 | #include "HsVersions.h" 34 | 35 | -- ghci-ng 36 | import GhciTypes 37 | import Data.Map.Strict (Map) 38 | import qualified GHC 39 | import GhcMonad hiding (liftIO) 40 | import Outputable hiding (printForUser, printForUserPartWay) 41 | import qualified Outputable 42 | import Util 43 | import DynFlags 44 | import HscTypes 45 | import SrcLoc 46 | import Module 47 | #if __GLASGOW_HASKELL__ >= 800 48 | import GHCi.ObjLink as ObjLink 49 | import GHC (BreakIndex) 50 | #else 51 | import ObjLink 52 | #endif 53 | import Linker 54 | 55 | import Exception 56 | import Numeric 57 | import Data.Array 58 | import Data.Int ( Int64 ) 59 | import Data.IORef 60 | import System.CPUTime 61 | import System.Environment 62 | import System.IO 63 | #if __GLASGOW_HASKELL__ < 709 64 | import Control.Applicative (Applicative(..)) 65 | #endif 66 | import Control.Monad 67 | import GHC.Exts 68 | 69 | import System.Console.Haskeline (CompletionFunc, InputT) 70 | import qualified System.Console.Haskeline as Haskeline 71 | import Control.Monad.Trans.Class 72 | import Control.Monad.IO.Class 73 | 74 | ----------------------------------------------------------------------------- 75 | -- GHCi monad 76 | 77 | type Command = (String, String -> InputT GHCi Bool, CompletionFunc GHCi) 78 | 79 | data GHCiState = GHCiState 80 | { 81 | progname :: String, 82 | args :: [String], 83 | prompt :: String, 84 | prompt2 :: String, 85 | editor :: String, 86 | stop :: String, 87 | options :: [GHCiOption], 88 | line_number :: !Int, -- input line 89 | break_ctr :: !Int, 90 | breaks :: ![(Int, BreakLocation)], 91 | tickarrays :: ModuleEnv TickArray, 92 | -- tickarrays caches the TickArray for loaded modules, 93 | -- so that we don't rebuild it each time the user sets 94 | -- a breakpoint. 95 | -- available ghci commands 96 | ghci_commands :: [Command], 97 | -- ":" at the GHCi prompt repeats the last command, so we 98 | -- remember is here: 99 | last_command :: Maybe Command, 100 | cmdqueue :: [String], 101 | 102 | remembered_ctx :: [InteractiveImport], 103 | -- the imports that the user has asked for, via import 104 | -- declarations and :module commands. This list is 105 | -- persistent over :reloads (but any imports for modules 106 | -- that are not loaded are temporarily ignored). After a 107 | -- :load, all the home-package imports are stripped from 108 | -- this list. 109 | 110 | -- See bugs #2049, #1873, #1360 111 | 112 | transient_ctx :: [InteractiveImport], 113 | -- An import added automatically after a :load, usually of 114 | -- the most recently compiled module. May be empty if 115 | -- there are no modules loaded. This list is replaced by 116 | -- :load, :reload, and :add. In between it may be modified 117 | -- by :module. 118 | 119 | ghc_e :: Bool, -- True if this is 'ghc -e' (or runghc) 120 | 121 | -- help text to display to a user 122 | short_help :: String, 123 | long_help :: String, 124 | 125 | -- stored state 126 | mod_infos :: !(Map ModuleName ModInfo), 127 | rdrNamesInScope :: ![GHC.RdrName], 128 | 129 | ghci_work_directory :: FilePath, 130 | -- ^ Used to store the working directory associated with 131 | -- GHCi. This is what the current directory will be reverted 132 | -- to after calls to GHC.load. 133 | ghc_work_directory :: FilePath 134 | -- ^ Used as the working directory during calls to GHC.load. 135 | -- After the call to GHC.load completes, the current working 136 | -- directory will be reverted to the value of 137 | -- `ghci_work_directory`. 138 | } 139 | 140 | type TickArray = Array Int [(BreakIndex,SrcSpan)] 141 | 142 | data GHCiOption 143 | = ShowTiming -- show time/allocs after evaluation 144 | | ShowType -- show the type of expressions 145 | | RevertCAFs -- revert CAFs after every evaluation 146 | | Multiline -- use multiline commands 147 | deriving Eq 148 | 149 | data BreakLocation 150 | = BreakLocation 151 | { breakModule :: !GHC.Module 152 | , breakLoc :: !SrcSpan 153 | , breakTick :: {-# UNPACK #-} !Int 154 | , onBreakCmd :: String 155 | } 156 | 157 | instance Eq BreakLocation where 158 | loc1 == loc2 = breakModule loc1 == breakModule loc2 && 159 | breakTick loc1 == breakTick loc2 160 | 161 | prettyLocations :: [(Int, BreakLocation)] -> SDoc 162 | prettyLocations [] = text "No active breakpoints." 163 | prettyLocations locs = vcat $ map (\(i, loc) -> brackets (int i) <+> ppr loc) $ reverse $ locs 164 | 165 | instance Outputable BreakLocation where 166 | ppr loc = (ppr $ breakModule loc) <+> ppr (breakLoc loc) <+> 167 | if null (onBreakCmd loc) 168 | then empty 169 | else doubleQuotes (text (onBreakCmd loc)) 170 | 171 | recordBreak :: BreakLocation -> GHCi (Bool{- was already present -}, Int) 172 | recordBreak brkLoc = do 173 | st <- getGHCiState 174 | let oldActiveBreaks = breaks st 175 | -- don't store the same break point twice 176 | case [ nm | (nm, loc) <- oldActiveBreaks, loc == brkLoc ] of 177 | (nm:_) -> return (True, nm) 178 | [] -> do 179 | let oldCounter = break_ctr st 180 | newCounter = oldCounter + 1 181 | setGHCiState $ st { break_ctr = newCounter, 182 | breaks = (oldCounter, brkLoc) : oldActiveBreaks 183 | } 184 | return (False, oldCounter) 185 | 186 | newtype GHCi a = GHCi { unGHCi :: IORef GHCiState -> Ghc a } 187 | 188 | reflectGHCi :: (Session, IORef GHCiState) -> GHCi a -> IO a 189 | reflectGHCi (s, gs) m = unGhc (unGHCi m gs) s 190 | 191 | reifyGHCi :: ((Session, IORef GHCiState) -> IO a) -> GHCi a 192 | reifyGHCi f = GHCi f' 193 | where 194 | -- f' :: IORef GHCiState -> Ghc a 195 | f' gs = reifyGhc (f'' gs) 196 | -- f'' :: IORef GHCiState -> Session -> IO a 197 | f'' gs s = f (s, gs) 198 | 199 | startGHCi :: GHCi a -> IORef GHCiState -> Ghc a 200 | startGHCi g ref = unGHCi g ref 201 | 202 | instance Functor GHCi where 203 | fmap = liftM 204 | 205 | instance Applicative GHCi where 206 | pure = return 207 | (<*>) = ap 208 | 209 | instance Monad GHCi where 210 | (GHCi m) >>= k = GHCi $ \s -> m s >>= \a -> unGHCi (k a) s 211 | return a = GHCi $ \_ -> return a 212 | 213 | getGHCiState :: GHCi GHCiState 214 | getGHCiState = GHCi $ \r -> liftIO $ readIORef r 215 | setGHCiState :: GHCiState -> GHCi () 216 | setGHCiState s = GHCi $ \r -> liftIO $ writeIORef r s 217 | modifyGHCiState :: (GHCiState -> GHCiState) -> GHCi () 218 | modifyGHCiState f = GHCi $ \r -> liftIO $ readIORef r >>= writeIORef r . f 219 | 220 | liftGhc :: Ghc a -> GHCi a 221 | liftGhc m = GHCi $ \_ -> m 222 | 223 | instance MonadIO GHCi where 224 | liftIO = liftGhc . liftIO 225 | 226 | instance HasDynFlags GHCi where 227 | getDynFlags = getSessionDynFlags 228 | 229 | instance GhcMonad GHCi where 230 | setSession s' = liftGhc $ setSession s' 231 | getSession = liftGhc $ getSession 232 | 233 | instance HasDynFlags (InputT GHCi) where 234 | getDynFlags = lift getDynFlags 235 | 236 | instance GhcMonad (InputT GHCi) where 237 | setSession = lift . setSession 238 | getSession = lift getSession 239 | 240 | instance ExceptionMonad GHCi where 241 | gcatch m h = GHCi $ \r -> unGHCi m r `gcatch` (\e -> unGHCi (h e) r) 242 | gmask f = 243 | GHCi $ \s -> gmask $ \io_restore -> 244 | let 245 | g_restore (GHCi m) = GHCi $ \s' -> io_restore (m s') 246 | in 247 | unGHCi (f g_restore) s 248 | 249 | instance Haskeline.MonadException Ghc where 250 | controlIO f = Ghc $ \s -> Haskeline.controlIO $ \(Haskeline.RunIO run) -> let 251 | run' = Haskeline.RunIO (fmap (Ghc . const) . run . flip unGhc s) 252 | in fmap (flip unGhc s) $ f run' 253 | 254 | instance Haskeline.MonadException GHCi where 255 | controlIO f = GHCi $ \s -> Haskeline.controlIO $ \(Haskeline.RunIO run) -> let 256 | run' = Haskeline.RunIO (fmap (GHCi . const) . run . flip unGHCi s) 257 | in fmap (flip unGHCi s) $ f run' 258 | 259 | instance ExceptionMonad (InputT GHCi) where 260 | gcatch = Haskeline.catch 261 | gmask f = Haskeline.liftIOOp gmask (f . Haskeline.liftIOOp_) 262 | 263 | isOptionSet :: GHCiOption -> GHCi Bool 264 | isOptionSet opt 265 | = do st <- getGHCiState 266 | return (opt `elem` options st) 267 | 268 | setOption :: GHCiOption -> GHCi () 269 | setOption opt 270 | = do st <- getGHCiState 271 | setGHCiState (st{ options = opt : filter (/= opt) (options st) }) 272 | 273 | unsetOption :: GHCiOption -> GHCi () 274 | unsetOption opt 275 | = do st <- getGHCiState 276 | setGHCiState (st{ options = filter (/= opt) (options st) }) 277 | 278 | printForUserNeverQualify :: GhcMonad m => SDoc -> m () 279 | printForUserNeverQualify doc = do 280 | dflags <- getDynFlags 281 | liftIO $ Outputable.printForUser dflags stdout neverQualify doc 282 | 283 | printForUserModInfo :: GhcMonad m => Handle -> GHC.ModuleInfo -> SDoc -> m () 284 | printForUserModInfo h info doc = do 285 | dflags <- getDynFlags 286 | mUnqual <- GHC.mkPrintUnqualifiedForModule info 287 | unqual <- maybe GHC.getPrintUnqual return mUnqual 288 | liftIO $ Outputable.printForUser dflags h unqual doc 289 | 290 | printForUser :: GhcMonad m => Handle -> SDoc -> m () 291 | printForUser h doc = do 292 | unqual <- GHC.getPrintUnqual 293 | dflags <- getDynFlags 294 | liftIO $ Outputable.printForUser dflags h unqual doc 295 | 296 | printForUserPartWay :: SDoc -> GHCi () 297 | printForUserPartWay doc = do 298 | unqual <- GHC.getPrintUnqual 299 | dflags <- getDynFlags 300 | liftIO $ Outputable.printForUserPartWay dflags stdout (pprUserLength dflags) unqual doc 301 | 302 | -- | Run a single Haskell expression 303 | #if __GLASGOW_HASKELL__ >= 802 304 | runStmt :: String -> GHC.SingleStep -> GHCi (Maybe GHC.ExecResult) 305 | runStmt expr step = do 306 | st <- getGHCiState 307 | reifyGHCi $ \x -> 308 | withProgName (progname st) $ 309 | withArgs (args st) $ 310 | reflectGHCi x $ do 311 | GHC.handleSourceError (\e -> do GHC.printException e; 312 | return Nothing) $ do 313 | r <- GHC.execStmt expr (GHC.execOptions { GHC.execSingleStep = step }) 314 | return (Just r) 315 | #else 316 | runStmt :: String -> GHC.SingleStep -> GHCi (Maybe GHC.RunResult) 317 | runStmt expr step = do 318 | st <- getGHCiState 319 | reifyGHCi $ \x -> 320 | withProgName (progname st) $ 321 | withArgs (args st) $ 322 | reflectGHCi x $ do 323 | GHC.handleSourceError (\e -> do GHC.printException e; 324 | return Nothing) $ do 325 | r <- GHC.runStmtWithLocation (progname st) (line_number st) expr step 326 | return (Just r) 327 | #endif 328 | 329 | runDecls :: String -> GHCi [GHC.Name] 330 | runDecls decls = do 331 | st <- getGHCiState 332 | reifyGHCi $ \x -> 333 | withProgName (progname st) $ 334 | withArgs (args st) $ 335 | reflectGHCi x $ do 336 | GHC.handleSourceError (\e -> do GHC.printException e; return []) $ do 337 | GHC.runDeclsWithLocation (progname st) (line_number st) decls 338 | 339 | #if __GLASGOW_HASKELL__ >= 802 340 | resume :: (SrcSpan -> Bool) -> GHC.SingleStep -> GHCi GHC.ExecResult 341 | resume canLogSpan step = do 342 | st <- getGHCiState 343 | reifyGHCi $ \x -> 344 | withProgName (progname st) $ 345 | withArgs (args st) $ 346 | reflectGHCi x $ do 347 | GHC.resumeExec canLogSpan step 348 | #else 349 | resume :: (SrcSpan -> Bool) -> GHC.SingleStep -> GHCi GHC.RunResult 350 | resume canLogSpan step = do 351 | st <- getGHCiState 352 | reifyGHCi $ \x -> 353 | withProgName (progname st) $ 354 | withArgs (args st) $ 355 | reflectGHCi x $ do 356 | GHC.resume canLogSpan step 357 | #endif 358 | 359 | -- -------------------------------------------------------------------------- 360 | -- timing & statistics 361 | 362 | timeIt :: InputT GHCi a -> InputT GHCi a 363 | timeIt action 364 | = do b <- lift $ isOptionSet ShowTiming 365 | if not b 366 | then action 367 | else do allocs1 <- liftIO $ getAllocations 368 | time1 <- liftIO $ getCPUTime 369 | a <- action 370 | allocs2 <- liftIO $ getAllocations 371 | time2 <- liftIO $ getCPUTime 372 | dflags <- getDynFlags 373 | liftIO $ printTimes dflags (fromIntegral (allocs2 - allocs1)) 374 | (time2 - time1) 375 | return a 376 | 377 | foreign import ccall unsafe "getAllocations" getAllocations :: IO Int64 378 | -- defined in ghc/rts/Stats.c 379 | 380 | printTimes :: DynFlags -> Integer -> Integer -> IO () 381 | printTimes dflags allocs psecs 382 | = do let secs = (fromIntegral psecs / (10^(12::Integer))) :: Float 383 | secs_str = showFFloat (Just 2) secs 384 | putStrLn (showSDoc dflags ( 385 | parens (text (secs_str "") <+> text "secs" Outputable.<> comma <+> 386 | text (show allocs) <+> text "bytes"))) 387 | 388 | ----------------------------------------------------------------------------- 389 | -- reverting CAFs 390 | 391 | revertCAFs :: GHCi () 392 | revertCAFs = do 393 | liftIO rts_revertCAFs 394 | s <- getGHCiState 395 | when (not (ghc_e s)) $ liftIO turnOffBuffering 396 | -- Have to turn off buffering again, because we just 397 | -- reverted stdout, stderr & stdin to their defaults. 398 | 399 | foreign import ccall "revertCAFs" rts_revertCAFs :: IO () 400 | -- Make it "safe", just in case 401 | 402 | ----------------------------------------------------------------------------- 403 | -- To flush buffers for the *interpreted* computation we need 404 | -- to refer to *its* stdout/stderr handles 405 | 406 | GLOBAL_VAR(stdin_ptr, error "no stdin_ptr", Ptr ()) 407 | GLOBAL_VAR(stdout_ptr, error "no stdout_ptr", Ptr ()) 408 | GLOBAL_VAR(stderr_ptr, error "no stderr_ptr", Ptr ()) 409 | 410 | -- After various attempts, I believe this is the least bad way to do 411 | -- what we want. We know look up the address of the static stdin, 412 | -- stdout, and stderr closures in the loaded base package, and each 413 | -- time we need to refer to them we cast the pointer to a Handle. 414 | -- This avoids any problems with the CAF having been reverted, because 415 | -- we'll always get the current value. 416 | -- 417 | -- The previous attempt that didn't work was to compile an expression 418 | -- like "hSetBuffering stdout NoBuffering" into an expression of type 419 | -- IO () and run this expression each time we needed it, but the 420 | -- problem is that evaluating the expression might cache the contents 421 | -- of the Handle rather than referring to it from its static address 422 | -- each time. There's no safe workaround for this. 423 | 424 | initInterpBuffering :: Ghc () 425 | initInterpBuffering = do -- make sure these are linked 426 | #if __GLASGOW_HASKELL__ < 800 427 | dflags <- GHC.getSessionDynFlags 428 | #else 429 | hscEnv <- getSession 430 | #endif 431 | liftIO $ do 432 | #if __GLASGOW_HASKELL__ >= 800 433 | initDynLinker hscEnv 434 | #else 435 | initDynLinker dflags 436 | #endif 437 | 438 | -- ToDo: we should really look up these names properly, but 439 | -- it's a fiddle and not all the bits are exposed via the GHC 440 | -- interface. 441 | mb_stdin_ptr <- ObjLink.lookupSymbol "base_GHCziIOziHandleziFD_stdin_closure" 442 | mb_stdout_ptr <- ObjLink.lookupSymbol "base_GHCziIOziHandleziFD_stdout_closure" 443 | mb_stderr_ptr <- ObjLink.lookupSymbol "base_GHCziIOziHandleziFD_stderr_closure" 444 | 445 | let f ref (Just ptr) = writeIORef ref ptr 446 | f _ Nothing = panic "interactiveUI:setBuffering2" 447 | zipWithM_ f [stdin_ptr,stdout_ptr,stderr_ptr] 448 | [mb_stdin_ptr,mb_stdout_ptr,mb_stderr_ptr] 449 | 450 | flushInterpBuffers :: GHCi () 451 | flushInterpBuffers 452 | = liftIO $ do getHandle stdout_ptr >>= hFlush 453 | getHandle stderr_ptr >>= hFlush 454 | 455 | turnOffBuffering :: IO () 456 | turnOffBuffering 457 | = do hdls <- mapM getHandle [stdin_ptr,stdout_ptr,stderr_ptr] 458 | mapM_ (\h -> hSetBuffering h NoBuffering) hdls 459 | 460 | getHandle :: IORef (Ptr ()) -> IO Handle 461 | getHandle ref = do 462 | (Ptr addr) <- readIORef ref 463 | case addrToAny# addr of (# hval #) -> return (unsafeCoerce# hval) 464 | -------------------------------------------------------------------------------- /src/GhciTags.hs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- 3 | -- GHCi's :ctags and :etags commands 4 | -- 5 | -- (c) The GHC Team 2005-2007 6 | -- 7 | ----------------------------------------------------------------------------- 8 | 9 | {-# OPTIONS_GHC -fno-warn-name-shadowing #-} 10 | module GhciTags ( 11 | createCTagsWithLineNumbersCmd, 12 | createCTagsWithRegExesCmd, 13 | createETagsFileCmd 14 | ) where 15 | 16 | import Exception 17 | import GHC 18 | import GhciMonad 19 | import Intero.Compat 20 | import Outputable 21 | 22 | -- ToDo: figure out whether we need these, and put something appropriate 23 | -- into the GHC API instead 24 | import Name (nameOccName) 25 | import OccName (pprOccName) 26 | import ConLike 27 | import MonadUtils 28 | 29 | import Data.Function 30 | import Data.Maybe 31 | import Data.Ord 32 | import Panic 33 | import Data.List 34 | import Control.Monad 35 | import System.IO 36 | import System.IO.Error 37 | 38 | ----------------------------------------------------------------------------- 39 | -- create tags file for currently loaded modules. 40 | 41 | createCTagsWithLineNumbersCmd, createCTagsWithRegExesCmd, 42 | createETagsFileCmd :: String -> GHCi () 43 | 44 | createCTagsWithLineNumbersCmd "" = 45 | ghciCreateTagsFile CTagsWithLineNumbers "tags" 46 | createCTagsWithLineNumbersCmd file = 47 | ghciCreateTagsFile CTagsWithLineNumbers file 48 | 49 | createCTagsWithRegExesCmd "" = 50 | ghciCreateTagsFile CTagsWithRegExes "tags" 51 | createCTagsWithRegExesCmd file = 52 | ghciCreateTagsFile CTagsWithRegExes file 53 | 54 | createETagsFileCmd "" = ghciCreateTagsFile ETags "TAGS" 55 | createETagsFileCmd file = ghciCreateTagsFile ETags file 56 | 57 | data TagsKind = ETags | CTagsWithLineNumbers | CTagsWithRegExes 58 | 59 | ghciCreateTagsFile :: TagsKind -> FilePath -> GHCi () 60 | ghciCreateTagsFile kind file = do 61 | createTagsFile kind file 62 | 63 | -- ToDo: 64 | -- - remove restriction that all modules must be interpreted 65 | -- (problem: we don't know source locations for entities unless 66 | -- we compiled the module. 67 | -- 68 | -- - extract createTagsFile so it can be used from the command-line 69 | -- (probably need to fix first problem before this is useful). 70 | -- 71 | createTagsFile :: TagsKind -> FilePath -> GHCi () 72 | createTagsFile tagskind tagsFile = do 73 | graph <- ghc_getModuleGraph 74 | mtags <- mapM listModuleTags (map GHC.ms_mod graph) 75 | either_res <- liftIO $ collateAndWriteTags tagskind tagsFile $ concat mtags 76 | case either_res of 77 | Left e -> liftIO $ hPutStrLn stderr $ ioeGetErrorString e 78 | Right _ -> return () 79 | 80 | 81 | listModuleTags :: GHC.Module -> GHCi [TagInfo] 82 | listModuleTags m = do 83 | is_interpreted <- GHC.moduleIsInterpreted m 84 | -- should we just skip these? 85 | when (not is_interpreted) $ 86 | let mName = GHC.moduleNameString (GHC.moduleName m) in 87 | throwGhcException (CmdLineError ("module '" ++ mName ++ "' is not interpreted")) 88 | mbModInfo <- GHC.getModuleInfo m 89 | case mbModInfo of 90 | Nothing -> return [] 91 | Just mInfo -> do 92 | dflags <- getDynFlags 93 | mb_print_unqual <- GHC.mkPrintUnqualifiedForModule mInfo 94 | let unqual = fromMaybe GHC.alwaysQualify mb_print_unqual 95 | let names = fromMaybe [] $GHC.modInfoTopLevelScope mInfo 96 | let localNames = filter ((m==) . nameModule) names 97 | mbTyThings <- mapM GHC.lookupName localNames 98 | return $! [ tagInfo dflags unqual exported kind name realLoc 99 | | tyThing <- catMaybes mbTyThings 100 | , let name = getName tyThing 101 | , let exported = GHC.modInfoIsExportedName mInfo name 102 | , let kind = tyThing2TagKind tyThing 103 | , let loc = srcSpanStart (nameSrcSpan name) 104 | , RealSrcLoc realLoc <- [loc] 105 | ] 106 | 107 | where 108 | tyThing2TagKind (AnId _) = 'v' 109 | tyThing2TagKind (AConLike RealDataCon{}) = 'd' 110 | tyThing2TagKind (AConLike PatSynCon{}) = 'p' 111 | tyThing2TagKind (ATyCon _) = 't' 112 | tyThing2TagKind (ACoAxiom _) = 'x' 113 | 114 | 115 | data TagInfo = TagInfo 116 | { tagExported :: Bool -- is tag exported 117 | , tagKind :: Char -- tag kind 118 | , tagName :: String -- tag name 119 | , tagFile :: String -- file name 120 | , tagLine :: Int -- line number 121 | , tagCol :: Int -- column number 122 | , tagSrcInfo :: Maybe (String,Integer) -- source code line and char offset 123 | } 124 | 125 | 126 | -- get tag info, for later translation into Vim or Emacs style 127 | tagInfo :: DynFlags -> PrintUnqualified -> Bool -> Char -> Name -> RealSrcLoc 128 | -> TagInfo 129 | tagInfo dflags unqual exported kind name loc 130 | = TagInfo exported kind 131 | (showSDocForUser dflags unqual $ pprOccName (nameOccName name)) 132 | (showSDocForUser dflags unqual $ ftext (srcLocFile loc)) 133 | (srcLocLine loc) (srcLocCol loc) Nothing 134 | 135 | 136 | collateAndWriteTags :: TagsKind -> FilePath -> [TagInfo] -> IO (Either IOError ()) 137 | -- ctags style with the Ex exresion being just the line number, Vim et al 138 | collateAndWriteTags CTagsWithLineNumbers file tagInfos = do 139 | let tags = unlines $ sort $ map showCTag tagInfos 140 | tryIO (writeFile file tags) 141 | 142 | -- ctags style with the Ex exresion being a regex searching the line, Vim et al 143 | collateAndWriteTags CTagsWithRegExes file tagInfos = do -- ctags style, Vim et al 144 | tagInfoGroups <- makeTagGroupsWithSrcInfo tagInfos 145 | let tags = unlines $ sort $ map showCTag $concat tagInfoGroups 146 | tryIO (writeFile file tags) 147 | 148 | collateAndWriteTags ETags file tagInfos = do -- etags style, Emacs/XEmacs 149 | tagInfoGroups <- makeTagGroupsWithSrcInfo $filter tagExported tagInfos 150 | let tagGroups = map processGroup tagInfoGroups 151 | tryIO (writeFile file $ concat tagGroups) 152 | 153 | where 154 | processGroup [] = throwGhcException (CmdLineError "empty tag file group??") 155 | processGroup group@(tagInfo:_) = 156 | let tags = unlines $ map showETag group in 157 | "\x0c\n" ++ tagFile tagInfo ++ "," ++ show (length tags) ++ "\n" ++ tags 158 | 159 | 160 | makeTagGroupsWithSrcInfo :: [TagInfo] -> IO [[TagInfo]] 161 | makeTagGroupsWithSrcInfo tagInfos = do 162 | let groups = groupBy ((==) `on` tagFile) $ sortBy (comparing tagFile) tagInfos 163 | mapM addTagSrcInfo groups 164 | 165 | where 166 | addTagSrcInfo [] = throwGhcException (CmdLineError "empty tag file group??") 167 | addTagSrcInfo group@(tagInfo:_) = do 168 | file <- readFile $tagFile tagInfo 169 | let sortedGroup = sortBy (comparing tagLine) group 170 | return $ perFile sortedGroup 1 0 $ lines file 171 | 172 | perFile allTags@(tag:tags) cnt pos allLs@(l:ls) 173 | | tagLine tag > cnt = 174 | perFile allTags (cnt+1) (pos+fromIntegral(length l)) ls 175 | | tagLine tag == cnt = 176 | tag{ tagSrcInfo = Just(l,pos) } : perFile tags cnt pos allLs 177 | perFile _ _ _ _ = [] 178 | 179 | 180 | -- ctags format, for Vim et al 181 | showCTag :: TagInfo -> String 182 | showCTag ti = 183 | tagName ti ++ "\t" ++ tagFile ti ++ "\t" ++ tagCmd ++ ";\"\t" ++ 184 | tagKind ti : ( if tagExported ti then "" else "\tfile:" ) 185 | 186 | where 187 | tagCmd = 188 | case tagSrcInfo ti of 189 | Nothing -> show $tagLine ti 190 | Just (srcLine,_) -> "/^"++ foldr escapeSlashes [] srcLine ++"$/" 191 | 192 | where 193 | escapeSlashes '/' r = '\\' : '/' : r 194 | escapeSlashes '\\' r = '\\' : '\\' : r 195 | escapeSlashes c r = c : r 196 | 197 | 198 | -- etags format, for Emacs/XEmacs 199 | showETag :: TagInfo -> String 200 | showETag TagInfo{ tagName = tag, tagLine = lineNo, tagCol = colNo, 201 | tagSrcInfo = Just (srcLine,charPos) } 202 | = take (colNo - 1) srcLine ++ tag 203 | ++ "\x7f" ++ tag 204 | ++ "\x01" ++ show lineNo 205 | ++ "," ++ show charPos 206 | showETag _ = throwGhcException (CmdLineError "missing source file info in showETag") 207 | -------------------------------------------------------------------------------- /src/GhciTypes.hs: -------------------------------------------------------------------------------- 1 | -- | Types used separate to GHCi vanilla. 2 | 3 | module GhciTypes where 4 | 5 | import Data.Time 6 | import GHC 7 | import Intero.Compat 8 | import Outputable 9 | 10 | -- | Info about a module. This information is generated every time a 11 | -- module is loaded. 12 | data ModInfo = 13 | ModInfo {modinfoSummary :: !ModSummary 14 | -- ^ Summary generated by GHC. Can be used to access more 15 | -- information about the module. 16 | ,modinfoSpans :: ![SpanInfo] 17 | -- ^ Generated set of information about all spans in the 18 | -- module that correspond to some kind of identifier for 19 | -- which there will be type info and/or location info. 20 | ,modinfoInfo :: !ModuleInfo 21 | -- ^ Again, useful from GHC for accessing information 22 | -- (exports, instances, scope) from a module. 23 | ,modinfoLastUpdate :: !UTCTime 24 | -- ^ Last time the module was updated. 25 | ,modinfoImports :: ![LImportDecl StageReaderName] 26 | -- ^ Import declarations within this module. 27 | ,modinfoLocation :: !SrcSpan 28 | -- ^ The location of the module 29 | } 30 | 31 | -- | Type of some span of source code. Most of these fields are 32 | -- unboxed but Haddock doesn't show that. 33 | data SpanInfo = 34 | SpanInfo {spaninfoStartLine :: {-# UNPACK #-} !Int 35 | -- ^ Start line of the span. 36 | ,spaninfoStartCol :: {-# UNPACK #-} !Int 37 | -- ^ Start column of the span. 38 | ,spaninfoEndLine :: {-# UNPACK #-} !Int 39 | -- ^ End line of the span (absolute). 40 | ,spaninfoEndCol :: {-# UNPACK #-} !Int 41 | -- ^ End column of the span (absolute). 42 | ,spaninfoType :: !(Maybe Type) 43 | -- ^ A pretty-printed representation fo the type. 44 | ,spaninfoVar :: !(Maybe Id) 45 | -- ^ The actual 'Var' associated with the span, if 46 | -- any. This can be useful for accessing a variety of 47 | -- information about the identifier such as module, 48 | -- locality, definition location, etc. 49 | } 50 | 51 | instance Outputable SpanInfo where 52 | ppr (SpanInfo sl sc el ec ty v) = 53 | (int sl Outputable.<> 54 | text ":" Outputable.<> 55 | int sc Outputable.<> 56 | text "-") Outputable.<> 57 | (int el Outputable.<> 58 | text ":" Outputable.<> 59 | int ec Outputable.<> 60 | text ": ") Outputable.<> 61 | (ppr v Outputable.<> 62 | text " :: " Outputable.<> 63 | ppr ty) 64 | -------------------------------------------------------------------------------- /src/Intero/Compat.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | 3 | -- | Compatibility between GHC API versions. 4 | 5 | module Intero.Compat 6 | ( ghc_getModuleGraph 7 | , ghc_getInfo 8 | , ghc_defaultDynFlags 9 | , ghc_topSortModuleGraph 10 | , ghc_mkWarn 11 | , ghc_mkErr 12 | , ghc_errMsg 13 | , ghc_warnMsg 14 | , ghc_tyConFlavour 15 | , StageReaderName 16 | , StageReaderRdrName 17 | , StageReaderId 18 | ) where 19 | 20 | #if __GLASGOW_HASKELL__ > 800 21 | import TyCoRep 22 | #endif 23 | import TyCon 24 | #if __GLASGOW_HASKELL__ > 802 25 | import CmdLineParser 26 | #endif 27 | #if __GLASGOW_HASKELL__ >= 800 28 | import qualified Data.Graph as SCC 29 | #else 30 | import qualified Digraph as SCC 31 | #endif 32 | import DynFlags 33 | import GHC 34 | 35 | ghc_tyConFlavour :: TyCon -> String 36 | #if __GLASGOW_HASKELL__ > 802 37 | ghc_tyConFlavour n = 38 | if tyConFlavour n == ClassFlavour 39 | then "class" 40 | else "" 41 | #else 42 | #if __GLASGOW_HASKELL__ > 800 43 | ghc_tyConFlavour = tyConFlavour 44 | #else 45 | ghc_tyConFlavour _ = "" 46 | #endif 47 | #endif 48 | 49 | ghc_defaultDynFlags :: Settings -> DynFlags 50 | #if __GLASGOW_HASKELL__ <= 802 51 | ghc_defaultDynFlags = defaultDynFlags 52 | #else 53 | ghc_defaultDynFlags s = defaultDynFlags s mempty 54 | #endif 55 | 56 | ghc_getInfo :: GhcMonad m => Bool -> Name -> m (Maybe (TyThing, Fixity, [ClsInst], [FamInst])) 57 | #if __GLASGOW_HASKELL__ <= 802 58 | ghc_getInfo = getInfo 59 | #else 60 | ghc_getInfo x y = fmap (fmap (\(a,b,c,d,_) -> (a,b,c,d))) (getInfo x y) 61 | #endif 62 | 63 | ghc_getModuleGraph :: GhcMonad m => m [ModSummary] 64 | #if __GLASGOW_HASKELL__ <= 802 65 | ghc_getModuleGraph = GHC.getModuleGraph 66 | #else 67 | ghc_getModuleGraph = fmap mgModSummaries GHC.getModuleGraph 68 | #endif 69 | 70 | ghc_topSortModuleGraph :: Bool -> [ModSummary] -> Maybe ModuleName -> [SCC.SCC ModSummary] 71 | #if __GLASGOW_HASKELL__ <= 802 72 | ghc_topSortModuleGraph = GHC.topSortModuleGraph 73 | #else 74 | ghc_topSortModuleGraph bool sums may = GHC.topSortModuleGraph bool (mkModuleGraph sums) may 75 | #endif 76 | 77 | #if __GLASGOW_HASKELL__ <= 802 78 | type StageReaderName = Name 79 | #else 80 | type StageReaderName = GhcRn 81 | #endif 82 | 83 | #if __GLASGOW_HASKELL__ <= 802 84 | type StageReaderRdrName = RdrName 85 | #else 86 | type StageReaderRdrName = GhcPs 87 | #endif 88 | 89 | #if __GLASGOW_HASKELL__ <= 802 90 | type StageReaderId = Id 91 | #else 92 | type StageReaderId = GhcTc 93 | #endif 94 | 95 | #if __GLASGOW_HASKELL__ > 802 96 | ghc_mkWarn :: Located String -> Warn 97 | ghc_mkWarn = Warn CmdLineParser.NoReason 98 | #else 99 | ghc_mkWarn :: a -> a 100 | ghc_mkWarn = id 101 | #endif 102 | 103 | #if __GLASGOW_HASKELL__ > 802 104 | ghc_mkErr :: Located String -> Err 105 | ghc_mkErr = Err 106 | #else 107 | ghc_mkErr :: a -> a 108 | ghc_mkErr = id 109 | #endif 110 | 111 | #if __GLASGOW_HASKELL__ > 802 112 | ghc_errMsg :: Err -> Located String 113 | ghc_errMsg = errMsg 114 | #else 115 | ghc_errMsg :: a -> a 116 | ghc_errMsg = id 117 | #endif 118 | 119 | #if __GLASGOW_HASKELL__ > 802 120 | ghc_warnMsg :: Warn -> Located String 121 | ghc_warnMsg = warnMsg 122 | #else 123 | ghc_warnMsg :: a -> a 124 | ghc_warnMsg = id 125 | #endif 126 | -------------------------------------------------------------------------------- /src/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NondecreasingIndentation #-} 2 | {-# LANGUAGE CPP #-} 3 | {-# OPTIONS -fno-warn-incomplete-patterns -optc-DNON_POSIX_SOURCE -fno-warn-warnings-deprecations #-} 4 | {-# LANGUAGE ForeignFunctionInterface #-} 5 | 6 | ----------------------------------------------------------------------------- 7 | -- 8 | -- GHC Driver program 9 | -- 10 | -- (c) The University of Glasgow 2005 11 | -- 12 | ----------------------------------------------------------------------------- 13 | 14 | module Main (main) where 15 | 16 | -- The official GHC API 17 | import qualified Data.Version (showVersion) 18 | import qualified GHC 19 | import GHC ( -- DynFlags(..), HscTarget(..), 20 | -- GhcMode(..), GhcLink(..), 21 | Ghc, GhcMonad(..), 22 | LoadHowMuch(..) ) 23 | import CmdLineParser 24 | import qualified Paths_intero 25 | 26 | -- ghci-ng 27 | import qualified GHC.Paths 28 | import Intero.Compat 29 | 30 | -- Implementations of the various modes (--show-iface, mkdependHS. etc.) 31 | import LoadIface ( showIface ) 32 | import HscMain ( newHscEnv ) 33 | import DriverPipeline ( oneShot, compileFile ) 34 | import DriverMkDepend ( doMkDependHS ) 35 | #ifdef GHCI 36 | import InteractiveUI ( interactiveUI, ghciWelcomeMsg, defaultGhciSettings ) 37 | #endif 38 | 39 | 40 | -- Various other random stuff that we need 41 | import Config 42 | import Constants 43 | import HscTypes 44 | #if __GLASGOW_HASKELL__ < 709 45 | import Packages ( dumpPackages ) 46 | #else 47 | import Packages ( pprPackages ) 48 | #endif 49 | import DriverPhases 50 | import BasicTypes ( failed ) 51 | #if __GLASGOW_HASKELL__ < 802 52 | import StaticFlags 53 | #endif 54 | import DynFlags 55 | import ErrUtils 56 | import FastString 57 | import Outputable 58 | import SrcLoc 59 | import Util 60 | import Panic 61 | import MonadUtils ( liftIO ) 62 | 63 | -- Imports for --abi-hash 64 | import LoadIface ( loadUserInterface ) 65 | import Module ( mkModuleName ) 66 | #if __GLASGOW_HASKELL__ >= 802 67 | import Finder ( findImportedModule, cannotFindModule ) 68 | #else 69 | import Finder ( findImportedModule, cannotFindInterface ) 70 | #endif 71 | import TcRnMonad ( initIfaceCheck ) 72 | #if __GLASGOW_HASKELL__ >= 802 73 | import Binary ( openBinMem, put_ ) 74 | import BinFingerprint ( fingerprintBinMem ) 75 | #else 76 | import Binary ( openBinMem, put_, fingerprintBinMem ) 77 | #endif 78 | 79 | -- Standard Haskell libraries 80 | import System.IO 81 | import System.Environment 82 | import System.Exit 83 | import System.FilePath 84 | import Control.Monad 85 | import Data.Char 86 | import Data.List 87 | import Data.Maybe 88 | 89 | ----------------------------------------------------------------------------- 90 | -- ToDo: 91 | 92 | -- time commands when run with -v 93 | -- user ways 94 | -- Win32 support: proper signal handling 95 | -- reading the package configuration file is too slow 96 | -- -K 97 | 98 | ----------------------------------------------------------------------------- 99 | -- GHC's command-line interface 100 | 101 | main :: IO () 102 | main = do 103 | env <- getEnvironment 104 | initGCStatistics -- See Note [-Bsymbolic and hooks] 105 | hSetBuffering stdout LineBuffering 106 | hSetBuffering stderr LineBuffering 107 | GHC.defaultErrorHandler defaultFatalMessager defaultFlushOut $ do 108 | -- 1. extract the -B flag from the args 109 | argv00 <- fmap (filter (/= "-traditional")) 110 | getArgs 111 | if elem "--version" argv00 112 | then do putStrLn ("Intero " ++ Data.Version.showVersion Paths_intero.version) 113 | exitSuccess 114 | else return () 115 | case lookup "STACK_EXE" env of 116 | Just{} -> return () 117 | Nothing -> 118 | hPutStr stderr ("WARNING: it is HIGHLY RECOMMENDED to use intero with stack:\n\n" 119 | ++ " To install:\n" 120 | ++ " stack build intero\n\n" 121 | ++ " To run with no project:\n" 122 | ++ " stack exec intero\n" 123 | ++ " To run with your project:\n" 124 | ++ " stack ghci --with-ghc intero\n\n") 125 | let argv0 = ("-B" ++ GHC.Paths.libdir) : 126 | if any (`elem` argv00) ["--info", "--interactive", "--make", "-c"] 127 | then argv00 -- needed for "cabal repl --with-ghc=ghci-ng" 128 | else "--interactive" : argv00 129 | 130 | let (minusB_args, argv1) = partition ("-B" `isPrefixOf`) argv0 131 | mbMinusB | null minusB_args = Nothing 132 | | otherwise = Just (drop 2 (last minusB_args)) 133 | 134 | let argv1' = map (mkGeneralLocated "on the commandline") argv1 135 | 136 | #if __GLASGOW_HASKELL__ >= 802 137 | (mode, argv3, modeFlagWarnings) <- parseModeFlags argv1' 138 | let flagWarnings = modeFlagWarnings 139 | #else 140 | (argv2, staticFlagWarnings) <- GHC.parseStaticFlags argv1' 141 | (mode, argv3, modeFlagWarnings) <- parseModeFlags argv2 142 | let flagWarnings = staticFlagWarnings ++ modeFlagWarnings 143 | #endif 144 | 145 | -- If all we want to do is something like showing the version number 146 | -- then do it now, before we start a GHC session etc. This makes 147 | -- getting basic information much more resilient. 148 | 149 | -- In particular, if we wait until later before giving the version 150 | -- number then bootstrapping gets confused, as it tries to find out 151 | -- what version of GHC it's using before package.conf exists, so 152 | -- starting the session fails. 153 | case mode of 154 | Left preStartupMode -> 155 | do case preStartupMode of 156 | ShowSupportedExtensions -> showSupportedExtensions 157 | ShowVersion -> showVersion 158 | ShowNumVersion -> putStrLn cProjectVersion 159 | ShowOptions -> showOptions 160 | Right postStartupMode -> 161 | -- start our GHC session 162 | GHC.runGhc mbMinusB $ do 163 | 164 | dflags <- GHC.getSessionDynFlags 165 | 166 | case postStartupMode of 167 | Left preLoadMode -> 168 | liftIO $ do 169 | case preLoadMode of 170 | ShowInfo -> showInfo dflags 171 | ShowGhcUsage -> showGhcUsage dflags 172 | ShowGhciUsage -> showGhciUsage dflags 173 | PrintWithDynFlags f -> putStrLn (f dflags) 174 | Right postLoadMode -> 175 | main' postLoadMode dflags argv3 flagWarnings 176 | 177 | main' :: PostLoadMode -> DynFlags -> [Located String] -> [Located String] 178 | -> Ghc () 179 | main' postLoadMode dflags0 args flagWarnings = do 180 | -- set the default GhcMode, HscTarget and GhcLink. The HscTarget 181 | -- can be further adjusted on a module by module basis, using only 182 | -- the -fvia-C and -fasm flags. If the default HscTarget is not 183 | -- HscC or HscAsm, -fvia-C and -fasm have no effect. 184 | let dflt_target = hscTarget dflags0 185 | (mode, lang, link) 186 | = case postLoadMode of 187 | DoInteractive -> (CompManager, HscInterpreted, LinkInMemory) 188 | DoEval _ -> (CompManager, HscInterpreted, LinkInMemory) 189 | DoMake -> (CompManager, dflt_target, LinkBinary) 190 | DoMkDependHS -> (MkDepend, dflt_target, LinkBinary) 191 | DoAbiHash -> (OneShot, dflt_target, LinkBinary) 192 | _ -> (OneShot, dflt_target, LinkBinary) 193 | 194 | let dflags1 = case lang of 195 | HscInterpreted -> 196 | let platform = targetPlatform dflags0 197 | dflags0a = updateWays $ dflags0 { ways = interpWays } 198 | dflags0b = foldl gopt_set dflags0a 199 | $ concatMap (wayGeneralFlags platform) 200 | interpWays 201 | dflags0c = foldl gopt_unset dflags0b 202 | $ concatMap (wayUnsetGeneralFlags platform) 203 | interpWays 204 | in dflags0c 205 | _ -> 206 | dflags0 207 | dflags2 = dflags1{ ghcMode = mode, 208 | hscTarget = lang, 209 | ghcLink = link, 210 | verbosity = case postLoadMode of 211 | DoEval _ -> 0 212 | _other -> 1 213 | } 214 | 215 | -- turn on -fimplicit-import-qualified for GHCi now, so that it 216 | -- can be overriden from the command-line 217 | -- XXX: this should really be in the interactive DynFlags, but 218 | -- we don't set that until later in interactiveUI 219 | dflags3 | DoInteractive <- postLoadMode = imp_qual_enabled 220 | | DoEval _ <- postLoadMode = imp_qual_enabled 221 | | otherwise = dflags2 222 | where imp_qual_enabled = dflags2 `gopt_set` Opt_ImplicitImportQualified 223 | 224 | -- The rest of the arguments are "dynamic" 225 | -- Leftover ones are presumably files 226 | (dflags4, fileish_args, dynamicFlagWarnings) <- GHC.parseDynamicFlags dflags3 args 227 | 228 | GHC.prettyPrintGhcErrors dflags4 $ do 229 | 230 | let flagWarnings' = (map ghc_mkWarn flagWarnings) ++ dynamicFlagWarnings 231 | 232 | handleSourceError (\e -> do 233 | GHC.printException e 234 | liftIO $ exitWith (ExitFailure 1)) $ do 235 | liftIO $ handleFlagWarnings dflags4 flagWarnings' 236 | 237 | -- make sure we clean up after ourselves 238 | GHC.defaultCleanupHandler dflags4 $ do 239 | 240 | liftIO $ showBanner postLoadMode dflags4 241 | 242 | let 243 | -- To simplify the handling of filepaths, we normalise all filepaths right 244 | -- away - e.g., for win32 platforms, backslashes are converted 245 | -- into forward slashes. 246 | normal_fileish_paths = map (normalise . unLoc) fileish_args 247 | (srcs, objs) = partition_args normal_fileish_paths [] [] 248 | 249 | dflags5 = dflags4 { ldInputs = map (FileOption "") objs 250 | ++ ldInputs dflags4 } 251 | 252 | -- we've finished manipulating the DynFlags, update the session 253 | _ <- GHC.setSessionDynFlags dflags5 254 | dflags6 <- GHC.getSessionDynFlags 255 | hsc_env <- GHC.getSession 256 | 257 | ---------------- Display configuration ----------- 258 | when (verbosity dflags6 >= 4) $ 259 | #if __GLASGOW_HASKELL__ >= 802 260 | let dumpPackages flags = putStrLn $ show $ runSDoc (pprPackages flags) ctx 261 | where ctx = initSDocContext flags (defaultDumpStyle dflags6) 262 | in 263 | #elif __GLASGOW_HASKELL__ >= 709 264 | let dumpPackages flags = putStrLn $ show $ runSDoc (pprPackages flags) ctx 265 | where ctx = initSDocContext flags defaultDumpStyle 266 | in 267 | #endif 268 | liftIO $ dumpPackages dflags6 269 | 270 | # if __GLASGOW_HASKELL__ < 802 271 | when (verbosity dflags6 >= 3) $ do 272 | liftIO $ hPutStrLn stderr ("Hsc static flags: " ++ unwords staticFlags) 273 | #endif 274 | 275 | ---------------- Final sanity checking ----------- 276 | liftIO $ checkOptions postLoadMode dflags6 srcs objs 277 | 278 | ---------------- Do the business ----------- 279 | handleSourceError (\e -> do 280 | GHC.printException e 281 | liftIO $ exitWith (ExitFailure 1)) $ do 282 | case postLoadMode of 283 | ShowInterface f -> liftIO $ doShowIface dflags6 f 284 | DoMake -> doMake srcs 285 | DoMkDependHS -> doMkDependHS (map fst srcs) 286 | StopBefore p -> liftIO (oneShot hsc_env p srcs) 287 | DoInteractive -> ghciUI srcs Nothing 288 | DoEval exprs -> ghciUI srcs $ Just $ reverse exprs 289 | DoAbiHash -> abiHash srcs 290 | 291 | liftIO $ dumpFinalStats dflags6 292 | 293 | ghciUI :: [(FilePath, Maybe Phase)] -> Maybe [String] -> Ghc () 294 | #ifndef GHCI 295 | ghciUI _ _ = throwGhcException (CmdLineError "not built for interactive use") 296 | #else 297 | ghciUI = interactiveUI defaultGhciSettings 298 | #endif 299 | 300 | -- ----------------------------------------------------------------------------- 301 | -- Splitting arguments into source files and object files. This is where we 302 | -- interpret the -x option, and attach a (Maybe Phase) to each source 303 | -- file indicating the phase specified by the -x option in force, if any. 304 | 305 | partition_args :: [String] -> [(String, Maybe Phase)] -> [String] 306 | -> ([(String, Maybe Phase)], [String]) 307 | partition_args [] srcs objs = (reverse srcs, reverse objs) 308 | partition_args ("-x":suff:args) srcs objs 309 | | "none" <- suff = partition_args args srcs objs 310 | | StopLn <- phase = partition_args args srcs (slurp ++ objs) 311 | | otherwise = partition_args rest (these_srcs ++ srcs) objs 312 | where phase = startPhase suff 313 | (slurp,rest) = break (== "-x") args 314 | these_srcs = zip slurp (repeat (Just phase)) 315 | partition_args (arg:args) srcs objs 316 | | looks_like_an_input arg = partition_args args ((arg,Nothing):srcs) objs 317 | | otherwise = partition_args args srcs (arg:objs) 318 | 319 | {- 320 | We split out the object files (.o, .dll) and add them 321 | to ldInputs for use by the linker. 322 | 323 | The following things should be considered compilation manager inputs: 324 | 325 | - haskell source files (strings ending in .hs, .lhs or other 326 | haskellish extension), 327 | 328 | - module names (not forgetting hierarchical module names), 329 | 330 | - things beginning with '-' are flags that were not recognised by 331 | the flag parser, and we want them to generate errors later in 332 | checkOptions, so we class them as source files (#5921) 333 | 334 | - and finally we consider everything not containing a '.' to be 335 | a comp manager input, as shorthand for a .hs or .lhs filename. 336 | 337 | Everything else is considered to be a linker object, and passed 338 | straight through to the linker. 339 | -} 340 | looks_like_an_input :: String -> Bool 341 | looks_like_an_input m = isSourceFilename m 342 | || looksLikeModuleName m 343 | || "-" `isPrefixOf` m 344 | || '.' `notElem` m 345 | 346 | -- ----------------------------------------------------------------------------- 347 | -- Option sanity checks 348 | 349 | -- | Ensure sanity of options. 350 | -- 351 | -- Throws 'UsageError' or 'CmdLineError' if not. 352 | checkOptions :: PostLoadMode -> DynFlags -> [(String,Maybe Phase)] -> [String] -> IO () 353 | -- Final sanity checking before kicking off a compilation (pipeline). 354 | checkOptions mode dflags srcs objs = do 355 | -- Complain about any unknown flags 356 | let unknown_opts = [ f | (f@('-':_), _) <- srcs ] 357 | when (notNull unknown_opts) (unknownFlagsErr unknown_opts) 358 | 359 | when (notNull (filter wayRTSOnly (ways dflags)) 360 | && isInterpretiveMode mode) $ 361 | hPutStrLn stderr ("Warning: -debug, -threaded and -ticky are ignored by GHCi") 362 | 363 | -- -prof and --interactive are not a good combination 364 | when ((filter (not . wayRTSOnly) (ways dflags) /= interpWays) 365 | && isInterpretiveMode mode) $ 366 | do throwGhcException (UsageError 367 | "--interactive can't be used with -prof or -unreg.") 368 | -- -ohi sanity check 369 | if (isJust (outputHi dflags) && 370 | (isCompManagerMode mode || srcs `lengthExceeds` 1)) 371 | then throwGhcException (UsageError "-ohi can only be used when compiling a single source file") 372 | else do 373 | 374 | -- -o sanity checking 375 | if (srcs `lengthExceeds` 1 && isJust (outputFile dflags) 376 | && not (isLinkMode mode)) 377 | then throwGhcException (UsageError "can't apply -o to multiple source files") 378 | else do 379 | 380 | let not_linking = not (isLinkMode mode) || isNoLink (ghcLink dflags) 381 | 382 | when (not_linking && not (null objs)) $ 383 | hPutStrLn stderr ("Warning: the following files would be used as linker inputs, but linking is not being done: " ++ unwords objs) 384 | 385 | -- Check that there are some input files 386 | -- (except in the interactive case) 387 | if null srcs && (null objs || not_linking) && needsInputsMode mode 388 | then throwGhcException (UsageError "no input files") 389 | else do 390 | 391 | -- Verify that output files point somewhere sensible. 392 | verifyOutputFiles dflags 393 | 394 | 395 | -- Compiler output options 396 | 397 | -- called to verify that the output files & directories 398 | -- point somewhere valid. 399 | -- 400 | -- The assumption is that the directory portion of these output 401 | -- options will have to exist by the time 'verifyOutputFiles' 402 | -- is invoked. 403 | -- 404 | verifyOutputFiles :: DynFlags -> IO () 405 | verifyOutputFiles dflags = do 406 | -- not -odir: we create the directory for -odir if it doesn't exist (#2278). 407 | let ofile = outputFile dflags 408 | when (isJust ofile) $ do 409 | let fn = fromJust ofile 410 | flg <- doesDirNameExist fn 411 | when (not flg) (nonExistentDir "-o" fn) 412 | let ohi = outputHi dflags 413 | when (isJust ohi) $ do 414 | let hi = fromJust ohi 415 | flg <- doesDirNameExist hi 416 | when (not flg) (nonExistentDir "-ohi" hi) 417 | where 418 | nonExistentDir flg dir = 419 | throwGhcException (CmdLineError ("error: directory portion of " ++ 420 | show dir ++ " does not exist (used with " ++ 421 | show flg ++ " option.)")) 422 | 423 | ----------------------------------------------------------------------------- 424 | -- GHC modes of operation 425 | 426 | type Mode = Either PreStartupMode PostStartupMode 427 | type PostStartupMode = Either PreLoadMode PostLoadMode 428 | 429 | data PreStartupMode 430 | = ShowVersion -- ghc -V/--version 431 | | ShowNumVersion -- ghc --numeric-version 432 | | ShowSupportedExtensions -- ghc --supported-extensions 433 | | ShowOptions -- ghc --show-options 434 | 435 | showVersionMode, showNumVersionMode, showSupportedExtensionsMode, showOptionsMode :: Mode 436 | showVersionMode = mkPreStartupMode ShowVersion 437 | showNumVersionMode = mkPreStartupMode ShowNumVersion 438 | showSupportedExtensionsMode = mkPreStartupMode ShowSupportedExtensions 439 | showOptionsMode = mkPreStartupMode ShowOptions 440 | 441 | mkPreStartupMode :: PreStartupMode -> Mode 442 | mkPreStartupMode = Left 443 | 444 | isShowVersionMode :: Mode -> Bool 445 | isShowVersionMode (Left ShowVersion) = True 446 | isShowVersionMode _ = False 447 | 448 | isShowNumVersionMode :: Mode -> Bool 449 | isShowNumVersionMode (Left ShowNumVersion) = True 450 | isShowNumVersionMode _ = False 451 | 452 | data PreLoadMode 453 | = ShowGhcUsage -- ghc -? 454 | | ShowGhciUsage -- ghci -? 455 | | ShowInfo -- ghc --info 456 | | PrintWithDynFlags (DynFlags -> String) -- ghc --print-foo 457 | 458 | showGhcUsageMode, showGhciUsageMode, showInfoMode :: Mode 459 | showGhcUsageMode = mkPreLoadMode ShowGhcUsage 460 | showGhciUsageMode = mkPreLoadMode ShowGhciUsage 461 | showInfoMode = mkPreLoadMode ShowInfo 462 | 463 | printSetting :: String -> Mode 464 | printSetting k = mkPreLoadMode (PrintWithDynFlags f) 465 | where f dflags = fromMaybe (panic ("Setting not found: " ++ show k)) 466 | $ lookup k (compilerInfo dflags) 467 | 468 | mkPreLoadMode :: PreLoadMode -> Mode 469 | mkPreLoadMode = Right . Left 470 | 471 | isShowGhcUsageMode :: Mode -> Bool 472 | isShowGhcUsageMode (Right (Left ShowGhcUsage)) = True 473 | isShowGhcUsageMode _ = False 474 | 475 | isShowGhciUsageMode :: Mode -> Bool 476 | isShowGhciUsageMode (Right (Left ShowGhciUsage)) = True 477 | isShowGhciUsageMode _ = False 478 | 479 | data PostLoadMode 480 | = ShowInterface FilePath -- ghc --show-iface 481 | | DoMkDependHS -- ghc -M 482 | | StopBefore Phase -- ghc -E | -C | -S 483 | -- StopBefore StopLn is the default 484 | | DoMake -- ghc --make 485 | | DoInteractive -- ghc --interactive 486 | | DoEval [String] -- ghc -e foo -e bar => DoEval ["bar", "foo"] 487 | | DoAbiHash -- ghc --abi-hash 488 | 489 | doMkDependHSMode, doMakeMode, doInteractiveMode, doAbiHashMode :: Mode 490 | doMkDependHSMode = mkPostLoadMode DoMkDependHS 491 | doMakeMode = mkPostLoadMode DoMake 492 | doInteractiveMode = mkPostLoadMode DoInteractive 493 | doAbiHashMode = mkPostLoadMode DoAbiHash 494 | 495 | showInterfaceMode :: FilePath -> Mode 496 | showInterfaceMode fp = mkPostLoadMode (ShowInterface fp) 497 | 498 | stopBeforeMode :: Phase -> Mode 499 | stopBeforeMode phase = mkPostLoadMode (StopBefore phase) 500 | 501 | doEvalMode :: String -> Mode 502 | doEvalMode str = mkPostLoadMode (DoEval [str]) 503 | 504 | mkPostLoadMode :: PostLoadMode -> Mode 505 | mkPostLoadMode = Right . Right 506 | 507 | isDoInteractiveMode :: Mode -> Bool 508 | isDoInteractiveMode (Right (Right DoInteractive)) = True 509 | isDoInteractiveMode _ = False 510 | 511 | isStopLnMode :: Mode -> Bool 512 | isStopLnMode (Right (Right (StopBefore StopLn))) = True 513 | isStopLnMode _ = False 514 | 515 | isDoMakeMode :: Mode -> Bool 516 | isDoMakeMode (Right (Right DoMake)) = True 517 | isDoMakeMode _ = False 518 | 519 | #ifdef GHCI 520 | isInteractiveMode :: PostLoadMode -> Bool 521 | isInteractiveMode DoInteractive = True 522 | isInteractiveMode _ = False 523 | #endif 524 | 525 | -- isInterpretiveMode: byte-code compiler involved 526 | isInterpretiveMode :: PostLoadMode -> Bool 527 | isInterpretiveMode DoInteractive = True 528 | isInterpretiveMode (DoEval _) = True 529 | isInterpretiveMode _ = False 530 | 531 | needsInputsMode :: PostLoadMode -> Bool 532 | needsInputsMode DoMkDependHS = True 533 | needsInputsMode (StopBefore _) = True 534 | needsInputsMode DoMake = True 535 | needsInputsMode _ = False 536 | 537 | -- True if we are going to attempt to link in this mode. 538 | -- (we might not actually link, depending on the GhcLink flag) 539 | isLinkMode :: PostLoadMode -> Bool 540 | isLinkMode (StopBefore StopLn) = True 541 | isLinkMode DoMake = True 542 | isLinkMode DoInteractive = True 543 | isLinkMode (DoEval _) = True 544 | isLinkMode _ = False 545 | 546 | isCompManagerMode :: PostLoadMode -> Bool 547 | isCompManagerMode DoMake = True 548 | isCompManagerMode DoInteractive = True 549 | isCompManagerMode (DoEval _) = True 550 | isCompManagerMode _ = False 551 | 552 | -- ----------------------------------------------------------------------------- 553 | -- Parsing the mode flag 554 | 555 | parseModeFlags :: [Located String] 556 | -> IO (Mode, 557 | [Located String], 558 | [Located String]) 559 | parseModeFlags args = do 560 | let ((leftover, errs1, warns), (mModeFlag, errs2, flags')) = 561 | runCmdLine (processArgs mode_flags args) 562 | (Nothing, [], []) 563 | mode = case mModeFlag of 564 | Nothing -> doMakeMode 565 | Just (m, _) -> m 566 | errs = errs1 ++ map ghc_mkErr (map (mkGeneralLocated "on the commandline") errs2) 567 | when (not (null errs)) $ throwGhcException 568 | #if __GLASGOW_HASKELL__ < 709 569 | $ errorsToGhcException errs 570 | #else 571 | $ errorsToGhcException $ map (\(L sp e) -> (show sp, e)) (map ghc_errMsg errs) 572 | #endif 573 | return (mode, flags' ++ leftover, map ghc_warnMsg warns) 574 | 575 | type ModeM = CmdLineP (Maybe (Mode, String), [String], [Located String]) 576 | -- mode flags sometimes give rise to new DynFlags (eg. -C, see below) 577 | -- so we collect the new ones and return them. 578 | 579 | mode_flags :: [Flag ModeM] 580 | #if __GLASGOW_HASKELL__ < 709 581 | mode_flags = flags 582 | #else 583 | mode_flags = zipWith ($) flags ghcModes 584 | #endif 585 | where flags = concat [help, othr, prim] 586 | ------- help / version ------------------------------------------------- 587 | help = [ 588 | Flag "?" (PassFlag (setMode showGhcUsageMode)) 589 | , Flag "-help" (PassFlag (setMode showGhcUsageMode)) 590 | , Flag "V" (PassFlag (setMode showVersionMode)) 591 | , Flag "-version" (PassFlag (setMode showVersionMode)) 592 | , Flag "-numeric-version" (PassFlag (setMode showNumVersionMode)) 593 | , Flag "-info" (PassFlag (setMode showInfoMode)) 594 | , Flag "-show-options" (PassFlag (setMode showOptionsMode)) 595 | , Flag "-supported-languages" (PassFlag (setMode showSupportedExtensionsMode)) 596 | , Flag "-supported-extensions" (PassFlag (setMode showSupportedExtensionsMode)) 597 | ] 598 | othr = [ Flag k' (PassFlag (setMode (printSetting k))) 599 | | k <- ["Project version", 600 | "Booter version", 601 | "Stage", 602 | "Build platform", 603 | "Host platform", 604 | "Target platform", 605 | "Have interpreter", 606 | "Object splitting supported", 607 | "Have native code generator", 608 | "Support SMP", 609 | "Unregisterised", 610 | "Tables next to code", 611 | "RTS ways", 612 | "Leading underscore", 613 | "Debug on", 614 | "LibDir", 615 | "Global Package DB", 616 | "C compiler flags", 617 | "Gcc Linker flags", 618 | "Ld Linker flags"], 619 | let k' = "-print-" ++ map (replaceSpace . toLower) k 620 | replaceSpace ' ' = '-' 621 | replaceSpace c = c 622 | ] 623 | ------- interfaces ----------------------------------------------------- 624 | prim = [ Flag "-show-iface" (HasArg (\f -> setMode (showInterfaceMode f) 625 | "--show-iface")) 626 | 627 | ------- primary modes -------------------------------------------------- 628 | , Flag "c" (PassFlag (\f -> do setMode (stopBeforeMode StopLn) f 629 | addFlag "-no-link" f)) 630 | , Flag "M" (PassFlag (setMode doMkDependHSMode)) 631 | , Flag "E" (PassFlag (setMode (stopBeforeMode anyHsc))) 632 | , Flag "C" (PassFlag (setMode (stopBeforeMode HCc))) 633 | , Flag "S" (PassFlag (setMode (stopBeforeMode (as False)))) 634 | , Flag "-make" (PassFlag (setMode doMakeMode)) 635 | , Flag "-interactive" (PassFlag (setMode doInteractiveMode)) 636 | , Flag "-abi-hash" (PassFlag (setMode doAbiHashMode)) 637 | , Flag "e" (SepArg (\s -> setMode (doEvalMode s) "-e")) 638 | ] 639 | #if __GLASGOW_HASKELL__ >= 709 640 | ghcModes = cycle [AllModes] 641 | #endif 642 | 643 | setMode :: Mode -> String -> EwM ModeM () 644 | setMode newMode newFlag = liftEwM $ do 645 | (mModeFlag, errs, flags') <- getCmdLineState 646 | let (modeFlag', errs') = 647 | case mModeFlag of 648 | Nothing -> ((newMode, newFlag), errs) 649 | Just (oldMode, oldFlag) -> 650 | case (oldMode, newMode) of 651 | -- -c/--make are allowed together, and mean --make -no-link 652 | _ | isStopLnMode oldMode && isDoMakeMode newMode 653 | || isStopLnMode newMode && isDoMakeMode oldMode -> 654 | ((doMakeMode, "--make"), []) 655 | 656 | -- If we have both --help and --interactive then we 657 | -- want showGhciUsage 658 | _ | isShowGhcUsageMode oldMode && 659 | isDoInteractiveMode newMode -> 660 | ((showGhciUsageMode, oldFlag), []) 661 | | isShowGhcUsageMode newMode && 662 | isDoInteractiveMode oldMode -> 663 | ((showGhciUsageMode, newFlag), []) 664 | -- Otherwise, --help/--version/--numeric-version always win 665 | | isDominantFlag oldMode -> ((oldMode, oldFlag), []) 666 | | isDominantFlag newMode -> ((newMode, newFlag), []) 667 | -- We need to accumulate eval flags like "-e foo -e bar" 668 | (Right (Right (DoEval esOld)), 669 | Right (Right (DoEval [eNew]))) -> 670 | ((Right (Right (DoEval (eNew : esOld))), oldFlag), 671 | errs) 672 | -- Saying e.g. --interactive --interactive is OK 673 | _ | oldFlag == newFlag -> ((oldMode, oldFlag), errs) 674 | -- Otherwise, complain 675 | _ -> let err = flagMismatchErr oldFlag newFlag 676 | in ((oldMode, oldFlag), err : errs) 677 | putCmdLineState (Just modeFlag', errs', flags') 678 | where isDominantFlag f = isShowGhcUsageMode f || 679 | isShowGhciUsageMode f || 680 | isShowVersionMode f || 681 | isShowNumVersionMode f 682 | 683 | flagMismatchErr :: String -> String -> String 684 | flagMismatchErr oldFlag newFlag 685 | = "cannot use `" ++ oldFlag ++ "' with `" ++ newFlag ++ "'" 686 | 687 | addFlag :: String -> String -> EwM ModeM () 688 | addFlag s flag = liftEwM $ do 689 | (m, e, flags') <- getCmdLineState 690 | putCmdLineState (m, e, mkGeneralLocated loc s : flags') 691 | where loc = "addFlag by " ++ flag ++ " on the commandline" 692 | 693 | -- ---------------------------------------------------------------------------- 694 | -- Run --make mode 695 | 696 | doMake :: [(String,Maybe Phase)] -> Ghc () 697 | doMake srcs = do 698 | let (hs_srcs, non_hs_srcs) = partition haskellish srcs 699 | 700 | haskellish (f,Nothing) = 701 | looksLikeModuleName f || isHaskellUserSrcFilename f || '.' `notElem` f 702 | haskellish (_,Just phase) = 703 | phase `notElem` [as True, Cc, Cobjc, CmmCpp, Cmm, StopLn] 704 | 705 | hsc_env <- GHC.getSession 706 | 707 | -- if we have no haskell sources from which to do a dependency 708 | -- analysis, then just do one-shot compilation and/or linking. 709 | -- This means that "ghc Foo.o Bar.o -o baz" links the program as 710 | -- we expect. 711 | if (null hs_srcs) 712 | then liftIO (oneShot hsc_env StopLn srcs) 713 | else do 714 | 715 | o_files <- mapM (\x -> liftIO $ compileFile hsc_env StopLn x) 716 | non_hs_srcs 717 | dflags <- GHC.getSessionDynFlags 718 | let dflags' = dflags { ldInputs = map (FileOption "") o_files 719 | ++ ldInputs dflags } 720 | _ <- GHC.setSessionDynFlags dflags' 721 | 722 | targets <- mapM (uncurry GHC.guessTarget) hs_srcs 723 | GHC.setTargets targets 724 | ok_flag <- GHC.load LoadAllTargets 725 | 726 | when (failed ok_flag) (liftIO $ exitWith (ExitFailure 1)) 727 | return () 728 | 729 | 730 | -- --------------------------------------------------------------------------- 731 | -- --show-iface mode 732 | 733 | doShowIface :: DynFlags -> FilePath -> IO () 734 | doShowIface dflags file = do 735 | hsc_env <- newHscEnv dflags 736 | showIface hsc_env file 737 | 738 | -- --------------------------------------------------------------------------- 739 | -- Various banners and verbosity output. 740 | 741 | showBanner :: PostLoadMode -> DynFlags -> IO () 742 | showBanner _postLoadMode dflags = do 743 | let verb = verbosity dflags 744 | 745 | #ifdef GHCI 746 | -- Show the GHCi banner 747 | when (isInteractiveMode _postLoadMode && verb >= 1) $ putStrLn ghciWelcomeMsg 748 | #endif 749 | 750 | -- Display details of the configuration in verbose mode 751 | when (verb >= 2) $ 752 | do hPutStr stderr "Glasgow Haskell Compiler, Version " 753 | hPutStr stderr cProjectVersion 754 | hPutStr stderr ", stage " 755 | hPutStr stderr cStage 756 | hPutStr stderr " booted by GHC version " 757 | hPutStrLn stderr cBooterVersion 758 | 759 | -- We print out a Read-friendly string, but a prettier one than the 760 | -- Show instance gives us 761 | showInfo :: DynFlags -> IO () 762 | showInfo dflags = do 763 | let sq x = " [" ++ x ++ "\n ]" 764 | putStrLn $ sq $ intercalate "\n ," $ map show $ compilerInfo dflags 765 | 766 | showSupportedExtensions :: IO () 767 | showSupportedExtensions = mapM_ putStrLn supportedLanguagesAndExtensions 768 | 769 | showVersion :: IO () 770 | showVersion = putStrLn (cProjectName ++ ", version " ++ cProjectVersion) 771 | 772 | showOptions :: IO () 773 | showOptions = putStr (unlines availableOptions) 774 | where 775 | #if __GLASGOW_HASKELL__ >= 802 776 | availableOptions = map ((:) '-') $ 777 | getFlagNames mode_flags ++ 778 | getFlagNames flagsDynamic 779 | #else 780 | availableOptions = map ((:) '-') $ 781 | getFlagNames mode_flags ++ 782 | getFlagNames flagsDynamic ++ 783 | (filterUnwantedStatic . getFlagNames $ flagsStatic) ++ 784 | flagsStaticNames 785 | -- this is a hack to get rid of two unwanted entries that get listed 786 | -- as static flags. Hopefully this hack will disappear one day together 787 | -- with static flags 788 | filterUnwantedStatic = filter (\x -> not (x `elem` ["f", "fno-"])) 789 | #endif 790 | getFlagNames opts = map getFlagName opts 791 | #if __GLASGOW_HASKELL__ >= 710 792 | getFlagName (Flag name _ _) = name 793 | #else 794 | getFlagName (Flag name _) = name 795 | #endif 796 | 797 | showGhcUsage :: DynFlags -> IO () 798 | showGhcUsage = showUsage False 799 | 800 | showGhciUsage :: DynFlags -> IO () 801 | showGhciUsage = showUsage True 802 | 803 | showUsage :: Bool -> DynFlags -> IO () 804 | showUsage ghci dflags = do 805 | let usage_path = if ghci then ghciUsagePath dflags 806 | else ghcUsagePath dflags 807 | usage <- readFile usage_path 808 | dump usage 809 | where 810 | dump "" = return () 811 | dump ('$':'$':s) = putStr progName >> dump s 812 | dump (c:s) = putChar c >> dump s 813 | 814 | dumpFinalStats :: DynFlags -> IO () 815 | dumpFinalStats dflags = 816 | when (gopt Opt_D_faststring_stats dflags) $ dumpFastStringStats dflags 817 | 818 | dumpFastStringStats :: DynFlags -> IO () 819 | dumpFastStringStats dflags = do 820 | buckets <- getFastStringTable 821 | let (entries, longest, has_z) = countFS 0 0 0 buckets 822 | msg = text "FastString stats:" $$ 823 | nest 4 (vcat [text "size: " <+> int (length buckets), 824 | text "entries: " <+> int entries, 825 | text "longest chain: " <+> int longest, 826 | text "has z-encoding: " <+> (has_z `pcntOf` entries) 827 | ]) 828 | -- we usually get more "has z-encoding" than "z-encoded", because 829 | -- when we z-encode a string it might hash to the exact same string, 830 | -- which will is not counted as "z-encoded". Only strings whose 831 | -- Z-encoding is different from the original string are counted in 832 | -- the "z-encoded" total. 833 | putMsg dflags msg 834 | where 835 | x `pcntOf` y = int ((x * 100) `quot` y) Outputable.<> char '%' 836 | 837 | countFS :: Int -> Int -> Int -> [[FastString]] -> (Int, Int, Int) 838 | countFS entries longest has_z [] = (entries, longest, has_z) 839 | countFS entries longest has_z (b:bs) = 840 | let 841 | len = length b 842 | longest' = max len longest 843 | entries' = entries + len 844 | has_zs = length (filter hasZEncoding b) 845 | in 846 | countFS entries' longest' (has_z + has_zs) bs 847 | 848 | -- ----------------------------------------------------------------------------- 849 | -- ABI hash support 850 | 851 | {- 852 | ghc --abi-hash Data.Foo System.Bar 853 | 854 | Generates a combined hash of the ABI for modules Data.Foo and 855 | System.Bar. The modules must already be compiled, and appropriate -i 856 | options may be necessary in order to find the .hi files. 857 | 858 | This is used by Cabal for generating the InstalledPackageId for a 859 | package. The InstalledPackageId must change when the visible ABI of 860 | the package chagnes, so during registration Cabal calls ghc --abi-hash 861 | to get a hash of the package's ABI. 862 | -} 863 | 864 | abiHash :: [(String, Maybe Phase)] -> Ghc () 865 | abiHash strs = do 866 | hsc_env <- getSession 867 | let dflags = hsc_dflags hsc_env 868 | 869 | liftIO $ do 870 | 871 | let find_it str = do 872 | let modname = mkModuleName str 873 | r <- findImportedModule hsc_env modname Nothing 874 | case r of 875 | Found _ m -> return m 876 | _error -> throwGhcException $ CmdLineError $ showSDoc dflags $ 877 | #if __GLASGOW_HASKELL__ >= 802 878 | cannotFindModule dflags modname r 879 | #else 880 | cannotFindInterface dflags modname r 881 | #endif 882 | 883 | mods <- mapM find_it (map fst strs) 884 | 885 | let get_iface modl = loadUserInterface False (text "abiHash") modl 886 | #if __GLASGOW_HASKELL__ >= 802 887 | ifaces <- initIfaceCheck (text "") hsc_env $ mapM get_iface mods 888 | #else 889 | ifaces <- initIfaceCheck hsc_env $ mapM get_iface mods 890 | #endif 891 | 892 | bh <- openBinMem (3*1024) -- just less than a block 893 | put_ bh hiVersion 894 | -- package hashes change when the compiler version changes (for now) 895 | -- see #5328 896 | mapM_ (put_ bh . mi_mod_hash) ifaces 897 | f <- fingerprintBinMem bh 898 | 899 | putStrLn (showPpr dflags f) 900 | 901 | -- ----------------------------------------------------------------------------- 902 | -- Util 903 | 904 | unknownFlagsErr :: [String] -> a 905 | unknownFlagsErr fs = throwGhcException $ UsageError $ concatMap oneError fs 906 | where 907 | oneError f = 908 | "unrecognised flag: " ++ f ++ "\n" ++ 909 | (case fuzzyMatch f (nub compat_allFlags) of 910 | [] -> "" 911 | suggs -> "did you mean one of:\n" ++ unlines (map (" " ++) suggs)) 912 | 913 | {- Note [-Bsymbolic and hooks] 914 | ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 915 | -Bsymbolic is a flag that prevents the binding of references to global 916 | symbols to symbols outside the shared library being compiled (see `man 917 | ld`). When dynamically linking, we don't use -Bsymbolic on the RTS 918 | package: that is because we want hooks to be overridden by the user, 919 | we don't want to constrain them to the RTS package. 920 | 921 | Unfortunately this seems to have broken somehow on OS X: as a result, 922 | defaultHooks (in hschooks.c) is not called, which does not initialize 923 | the GC stats. As a result, this breaks things like `:set +s` in GHCi 924 | (#8754). As a hacky workaround, we instead call 'defaultHooks' 925 | directly to initalize the flags in the RTS. 926 | 927 | A biproduct of this, I believe, is that hooks are likely broken on OS 928 | X when dynamically linking. But this probably doesn't affect most 929 | people since we're linking GHC dynamically, but most things themselves 930 | link statically. 931 | -} 932 | 933 | foreign import ccall safe "initGCStatistics" 934 | initGCStatistics :: IO () 935 | 936 | -- | Compatibility between GHC 7.8.2 -> GHC 7.8.3. 937 | as :: Bool -> Phase 938 | #if MIN_VERSION_ghc(7,8,3) 939 | as = As 940 | #else 941 | as _ = As 942 | #endif 943 | 944 | compat_allFlags :: [String] 945 | #if __GLASGOW_HASKELL__ < 800 946 | compat_allFlags = allFlags 947 | #else 948 | compat_allFlags = allNonDeprecatedFlags 949 | #endif 950 | -------------------------------------------------------------------------------- /src/test/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | -- | Test that various commands work properly. 4 | 5 | module Main where 6 | 7 | import Control.Exception 8 | import Control.Monad.IO.Class 9 | import Control.Monad (when, forM_) 10 | import Data.Char 11 | import System.IO 12 | import System.IO.Temp 13 | import System.FilePath (()) 14 | import System.Process 15 | import System.Info (os) 16 | import Test.Hspec 17 | import Text.Regex 18 | 19 | -- | Main entry point. 20 | main :: IO () 21 | main = hspec spec 22 | 23 | -------------------------------------------------------------------------------- 24 | -- Test suite specification 25 | 26 | -- | Test suite. 27 | spec :: Spec 28 | spec = do 29 | argsparser 30 | basics 31 | load 32 | types 33 | alltypes 34 | use 35 | definition 36 | bytecode 37 | completion 38 | it "Support GHC 8.2 better" pending 39 | 40 | -- | Argument parsing should be user-friendly. 41 | argsparser :: Spec 42 | argsparser = 43 | describe 44 | "Arguments parser" 45 | (do issue 46 | ":type-at \"Foo Bar.hs\" 1 1 1 1" 47 | "https://github.com/commercialhaskell/intero/issues/25" 48 | (atFile 49 | ":type-at" 50 | "Foo Bar.hs" 51 | "x = 'a'" 52 | (1, 1, 1, 1, "x") 53 | id 54 | "x :: Char\n") 55 | issue 56 | ":type-at" 57 | "https://github.com/commercialhaskell/intero/issues/28" 58 | (eval 59 | ":type-at" 60 | ": Expected a span: \"\" \"\"\n")) 61 | 62 | maybeModuleStr :: String 63 | #if __GLASGOW_HASKELL__ >= 806 64 | maybeModuleStr = "GHC.Maybe" 65 | #else 66 | maybeModuleStr = "GHC.Base" 67 | #endif 68 | 69 | -- | Basic commands that should work out of the box. 70 | basics :: Spec 71 | basics = 72 | describe 73 | "Basics" 74 | (do it ":t 1" (eval ":t 1 :: Num a => a" "1 :: Num a => a :: Num a => a\n") 75 | it 76 | ":i Nothing" 77 | (do reply <- withIntero [] (\_ repl -> repl ":i Nothing") 78 | shouldBe 79 | (subRegex (mkRegex "Data.Maybe") reply "GHC.Base") 80 | ("data Maybe a = Nothing | ... \t-- Defined in " ++ (quote maybeModuleStr) ++ "\n")) 81 | it ":k Just" (eval ":k Maybe" "Maybe :: * -> *\n")) 82 | where 83 | quote s = opQuote : s ++ [clQuote] 84 | opQuote = case os of 85 | "mingw32" -> '`' 86 | _ -> '‘' 87 | clQuote = case os of 88 | "mingw32" -> '\'' 89 | _ -> '’' 90 | 91 | -- | Loading files and seeing the results. 92 | load :: Spec 93 | load = 94 | describe 95 | "Load" 96 | (do it 97 | ":l X.hs" 98 | (do result <- 99 | withIntero 100 | [] 101 | (\dir repl -> do 102 | writeFile (dir ++ "/X.hs") "x = 'a'" 103 | repl (":l X.hs")) 104 | shouldBe 105 | result 106 | (unlines 107 | [ "[1 of 1] Compiling Main ( X.hs, interpreted )" 108 | , "Ok, modules loaded: Main." 109 | , "Collecting type info for 1 module(s) ... "])) 110 | it 111 | ":l X.hs; :extensions X" 112 | (do result <- 113 | withIntero 114 | [] 115 | (\dir repl -> do 116 | writeFile (dir ++ "/X.hs") "{-# LANGUAGE ScopedTypeVariables #-}\nmodule X where\nx = 'a'" 117 | _ <- repl (":l X.hs") 118 | repl (":extensions X")) 119 | shouldBe 120 | (filter (== "ScopedTypeVariables") (words result)) 121 | ["ScopedTypeVariables"]) 122 | it 123 | ":l NonExistent.hs" 124 | (do result <- withIntero [] (\_ repl -> repl (":l NonExistent.hs")) 125 | shouldBe 126 | (stripError result) 127 | (unlines 128 | [ "Failed, modules loaded: none." 129 | , "" 130 | , ": can't find file: NonExistent.hs"]))) 131 | where 132 | stripError = \i -> subRegex (mkRegex "error: ") i "" 133 | 134 | -- | Check things when in -fbyte-code mode. 135 | bytecode :: Spec 136 | bytecode = 137 | describe 138 | "Bytecode" 139 | (do it 140 | ":set -fobject-code ; :l X.hs; :set -byte-code; :l X.hs" 141 | (do result <- 142 | withIntero 143 | [] 144 | (\dir repl -> do 145 | _ <- repl (":set -fobject-code") 146 | writeFile (dir ++ "/X.hs") "x = 'a'" 147 | _ <- repl (":l X.hs") 148 | _ <- repl (":set -fbyte-code") 149 | writeFile (dir ++ "/X.hs") "x = 123" 150 | repl (":l X.hs")) 151 | shouldBe 152 | (unlines (reverse (take 2 (reverse (lines result))))) 153 | (unlines 154 | [ "Ok, modules loaded: Main." 155 | , "Collecting type info for 1 module(s) ... "]))) 156 | 157 | -- | Get type information of file contents. 158 | types :: Spec 159 | types = 160 | describe 161 | "Types" 162 | (do it 163 | ":type-at X.hs 1 1 1 1 x -- Char" 164 | (typeAt "x = 'a'" (1, 1, 1, 1, "x") "x :: Char\n") 165 | it 166 | ":type-at X.hs 1 1 1 1 -- Char (string omitted)" 167 | (typeAt "x = 'a'" (1, 1, 1, 1, "") " :: Char\n") 168 | it 169 | ":type-at X.hs 1 1 1 1 x -- [Char]" 170 | (typeAt "x = 'a' : x" (1, 1, 1, 1, "x") "x :: [Char]\n") 171 | it 172 | ":type-at X.hs 1 11 1 12 x -- [Char]" 173 | (typeAt "x = 'a' : x" (1, 11, 1, 12, "x") "x :: [Char]\n") 174 | it 175 | ":type-at X.hs 1 11 1 12 y -- [Char] (internal variable)" 176 | (typeAt "x = 'a' : y where y = x" (1, 11, 1, 12, "y") "y :: [Char]\n") 177 | issue 178 | ":type-at X.hs 1 1 1 1 f -- Num a => a" 179 | "https://github.com/commercialhaskell/intero/issues/14" 180 | (typeAt "f x = x * 2" (1, 1, 1, 2, "f") "f :: Num a => a -> a\n") 181 | issue 182 | ":type-at X.hs 1 1 1 1 x -- Char (oddly bounded selection)" 183 | "https://github.com/commercialhaskell/intero/issues/29" 184 | (typeAt "foo = 'a'" (1, 1, 1, 1, "f") "f :: Char\n") 185 | issue 186 | ":type-at half of 2 arguments within function call" 187 | "https://github.com/commercialhaskell/intero/issues/29" 188 | (typeAt testFile (1, 29, 1, 32, "\" \"") "\" \" :: [Char] -> [Char]\n") 189 | issue 190 | ":type-at funtion + half of its first argument" 191 | "https://github.com/commercialhaskell/intero/issues/29" 192 | (typeAt 193 | testFile 194 | (1, 18, 1, 28, "concat3 \"a") 195 | "concat3 \"a :: [Char] -> [Char] -> [Char]\n") 196 | issue 197 | ":type-at 2 arguments within a function call" 198 | "https://github.com/commercialhaskell/intero/issues/29" 199 | (typeAt 200 | testFile 201 | (1, 26, 1, 35, "\"aa\" \"bb\"") 202 | "\"aa\" \"bb\" :: [Char] -> [Char]\n") 203 | issue 204 | ":type-at 2 lines within a do bloc" 205 | "https://github.com/commercialhaskell/intero/issues/29" 206 | (typeAt 207 | testFile 208 | (4, 8, 5, 10, "{{multiline}}") 209 | "{{multiline}} :: IO ()\n") 210 | issue 211 | ":type-at part of a line within a do bloc (1)" 212 | "https://github.com/commercialhaskell/intero/issues/29" 213 | (typeAt testFile (4, 8, 4, 10, " 1") " 1 :: IO ()\n") 214 | issue 215 | ":type-at part of a line within a do block (2)" 216 | "https://github.com/commercialhaskell/intero/issues/29" 217 | (typeAt testFile (4, 9, 4, 10, "1") "1 :: Integer\n") 218 | issue 219 | ":type-at with operator resolution" 220 | "https://github.com/commercialhaskell/intero/issues/47" 221 | (typeAt 222 | (unlines 223 | [ "data X = X" 224 | , "instance Show X where" 225 | , " show _ = show (1::Int,())" 226 | , "p s = id s * s == id s * s"]) 227 | (3, 18, 3, 19, "1") 228 | "1 :: Int\n")) 229 | where 230 | testFile :: String 231 | testFile = 232 | unlines 233 | [ "test = putStrLn (concat3 \"aa\" \"bb\" \"cc\")" 234 | , "concat3 a b c = a ++ b ++ c" 235 | , "foo = do" 236 | , " print 1" 237 | , " print 2" 238 | , " print 3" 239 | , ""] 240 | 241 | -- | List all types in all modules loaded. 242 | alltypes :: Spec 243 | alltypes = 244 | describe 245 | "All Types" 246 | (do it 247 | ":all-types" 248 | (do result <- 249 | withIntero 250 | [] 251 | (\dir repl -> do 252 | writeFile (dir ++ "/X.hs") "x = 123\ny = show 'c'" 253 | _ <- repl (":l X.hs") 254 | repl ":all-types") 255 | shouldBe 256 | result 257 | (unlines 258 | [ "X.hs:(2,1)-(2,2): String" 259 | , "X.hs:(1,1)-(1,2): Integer" 260 | , "X.hs:(2,5)-(2,9): Char -> String" 261 | , "X.hs:(2,10)-(2,13): Char" 262 | , "X.hs:(2,5)-(2,13): String" 263 | , "X.hs:(1,5)-(1,8): Integer"]))) 264 | 265 | -- | Are we on ghc8_2 or above? 266 | ghc8_2 :: Bool 267 | #if __GLASGOW_HASKELL__ >= 802 268 | ghc8_2 = True 269 | #else 270 | ghc8_2 = False 271 | #endif 272 | 273 | -- | Find uses of a variable. 274 | use :: Spec 275 | use = 276 | describe 277 | "Uses" 278 | (do it 279 | ":uses X.hs 1 1 1 1 x -- from definition site" 280 | (uses 281 | "x = 'a' : x" 282 | (1, 1, 1, 1, "x") 283 | id 284 | (unlines 285 | ["X.hs:(1,1)-(1,2)", "X.hs:(1,1)-(1,2)", "X.hs:(1,11)-(1,12)"])) 286 | it 287 | ":uses X.hs 1 11 1 12 x -- from use site" 288 | (uses 289 | "x = 'a' : x" 290 | (1, 11, 1, 12, "x") 291 | id 292 | (if ghc8_2 293 | then unlines ["X.hs:(1,1)-(1,2)","X.hs:(1,1)-(1,2)","X.hs:(1,11)-(1,12)"] 294 | else unlines ["X.hs:(1,1)-(1,2)", "X.hs:(1,11)-(1,12)"])) 295 | it 296 | ":uses X.hs 1 5 1 6 id -- package definition" 297 | (uses 298 | "x = id" 299 | (1, 5, 1, 6, "id") 300 | (\i -> subRegex (mkRegex "-[0-9]+\\.[0-9]+\\.[0-9]+\\.[0-9]+") i "") 301 | (unlines ["base:GHC.Base"])) 302 | it 303 | ":uses X.hs 1 5 1 6 id -- shadowed package definition" 304 | (uses 305 | "x = id where id = ()" 306 | (1, 5, 1, 7, "id") 307 | id 308 | (unlines 309 | ["X.hs:(1,14)-(1,16)", "X.hs:(1,14)-(1,16)", "X.hs:(1,5)-(1,7)"])) 310 | issue 311 | ":uses on type constructor (in data decl)" 312 | "https://github.com/commercialhaskell/intero/issues/3" 313 | (uses 314 | (unlines ["data X = X", "foo :: X -> X", "foo x = X"]) 315 | (1, 6, 1, 7, "X") 316 | lines 317 | ["X.hs:(1,1)-(1,11)"]) 318 | issue 319 | ":uses on type constructor (in sig)" 320 | "https://github.com/commercialhaskell/intero/issues/3" 321 | (uses 322 | (unlines ["data X = X", "foo :: X -> X", "foo x = X"]) 323 | (2, 8, 2, 9, "X") 324 | lines 325 | ["X.hs:(1,1)-(1,11)"]) 326 | issue 327 | ":uses on data constructor (in expression)" 328 | "https://github.com/commercialhaskell/intero/issues/3" 329 | (uses 330 | (unlines ["data X = X", "foo :: X -> X", "foo x = X"]) 331 | (3, 9, 3, 10, "X") 332 | lines 333 | (if ghc8_2 334 | then ["X.hs:(1,1)-(1,11)"] 335 | else ["X.hs:(1,10)-(1,11)", "X.hs:(3,9)-(3,10)"]))) 336 | 337 | -- | Find loc-ats of a variable. 338 | definition :: Spec 339 | definition = 340 | describe 341 | "Definition location" 342 | (do it 343 | "From definition site" 344 | (locAt "x = 'a' : x" (1, 1, 1, 1, "x") (unlines ["X.hs:(1,1)-(1,2)"])) 345 | it 346 | "From use site" 347 | (locAt 348 | "x = 'a' : x" 349 | (1, 11, 1, 12, "x") 350 | (unlines (if ghc8_2 351 | then ["X.hs:(1,1)-(1,2)"] 352 | else ["X.hs:(1,1)-(1,12)"]))) 353 | it 354 | "To function argument" 355 | (locAt 356 | "f x = 'a' : x" 357 | (1, 13, 1, 14, "x") 358 | (unlines ["X.hs:(1,3)-(1,4)"])) 359 | it 360 | "To pattern match" 361 | (locAt 362 | "f (Just x) = 'a' : x" 363 | (1, 20, 1, 21, "x") 364 | (unlines ["X.hs:(1,9)-(1,10)"])) 365 | it 366 | "To other module" 367 | (locAtMultiple 368 | [("X.hs", "import Y"), ("Y.hs", "module Y where")] 369 | (1, 8, 1, 9, "Y") 370 | (unlines ["." "Y.hs:(1,8)-(1,9)"])) 371 | issue 372 | "To unexported thing" 373 | "https://github.com/commercialhaskell/intero/issues/98" 374 | (locAt 375 | (unlines 376 | [ "module X () where" 377 | , "data MyType = MyCons" 378 | , "t :: MyType" 379 | , "t = MyCons :: MyType" 380 | ]) 381 | (3, 6, 3, 12, "MyType") 382 | (unlines ["X.hs:(2,1)-(2,21)"]))) 383 | 384 | -- | Test interactive completions. 385 | completion :: Spec 386 | completion = do 387 | describe 388 | "Completion in REPL" 389 | (do issue 390 | ":complete repl \"put\"" 391 | "https://github.com/commercialhaskell/intero/issues/34" 392 | (eval 393 | ":complete repl \"put\"" 394 | (unlines ["3 3 \"\"", "\"putChar\"", "\"putStr\"", "\"putStrLn\""])) 395 | issue 396 | ":complete repl \"sor\"" 397 | "https://github.com/commercialhaskell/intero/issues/34" 398 | (do reply <- 399 | withIntero 400 | [] 401 | (\_ repl -> do 402 | let req = ":complete repl \"sor\"" 403 | reply <- repl req 404 | if reply == "0 0 \"\"\n" 405 | then do 406 | _ <- repl "import Data.List" 407 | repl req 408 | else return ("First step failed: " ++ reply)) 409 | shouldBe 410 | (filter (/= "\"sortOn\"") (drop 1 (lines reply))) 411 | (["\"sort\"", "\"sortBy\""]))) 412 | describe 413 | "Completion in module context" 414 | (do when 415 | ghc8_2 416 | (issue 417 | ":complete-at for defered scope names" 418 | "https://github.com/chrisdone/intero/issues/531" 419 | (atFile 420 | ":complete-at" 421 | "X.hs" 422 | -- All these type annotations are required for GHC 8.6.5 423 | -- to accept the input without error. 424 | "{-# OPTIONS -fdefer-type-errors #-}\nmodule X where\ng a = fiiila (filu :: Char) a (fi :: Int)\n where fiiila _ _ _ = 123" 425 | (2, 14, 2, 17, "fi") 426 | lines 427 | ["fiiila", "filter"])) 428 | it 429 | ":complete-at for put*" 430 | (atFile 431 | ":complete-at" 432 | "X.hs" 433 | "module X () where\nx = undefined" 434 | (4, 5, 0, 0, "put") 435 | lines 436 | ["putChar", "putStr", "putStrLn"]) 437 | it 438 | ":complete-at for locally imported" 439 | (atFile 440 | ":complete-at" 441 | "X.hs" 442 | "module X () where\nimport Data.List\nx = undefined" 443 | (3, 5, 0, 0, "sor") 444 | (take 2 . lines) 445 | ["sort", "sortBy"]) 446 | it 447 | ":complete-at for module-locally defined" 448 | (atFile 449 | ":complete-at" 450 | "X.hs" 451 | "module X () where\nx = undefined\nmodlocal = ()" 452 | (2, 5, 0, 0, "modl") 453 | lines 454 | ["modlocal"]) 455 | it 456 | ":complete-at for definition-locally defined" 457 | (atFile 458 | ":complete-at" 459 | "X.hs" 460 | "module X () where\nx = undefined where locally = let p = 123 in p" 461 | (2, 5, 0, 0, "loc") 462 | lines 463 | ["locally"])) 464 | 465 | -------------------------------------------------------------------------------- 466 | -- Combinators for running and interacting with intero 467 | 468 | -- | Find the definition for the thing at point. 469 | locAtMultiple :: [(String, String)] -> (Int, Int, Int, Int, String) -> String -> Expectation 470 | locAtMultiple files (line,col,line',col',name) expected = do 471 | result <- 472 | withIntero 473 | [] 474 | (\dir repl -> do 475 | forM_ files $ \(fileName, fileContents) -> 476 | writeFile (dir ++ "/" ++ fileName) fileContents 477 | _ <- repl (":l " ++ fst (head files)) 478 | repl 479 | (":loc-at " ++ fst (head files) ++ " " ++ 480 | unwords (map show [line, col, line', col']) ++ " " ++ name)) 481 | shouldBe result expected 482 | let x = return () 483 | x 484 | 485 | locAt :: String -> (Int, Int, Int, Int, String) -> String -> Expectation 486 | locAt file = locAtMultiple [("X.hs", file)] 487 | 488 | -- | Find use-sites for the given place. 489 | uses 490 | :: (Eq a, Show a) 491 | => String -> (Int, Int, Int, Int, String) -> (String -> a) -> a -> Expectation 492 | uses file (line,col,line',col',name) preprocess expected = do 493 | result <- 494 | withIntero 495 | [] 496 | (\dir repl -> do 497 | writeFile (dir ++ "/X.hs") file 498 | _ <- repl (":l X.hs") 499 | repl 500 | (":uses X.hs " ++ 501 | unwords (map show [line, col, line', col']) ++ " " ++ name)) 502 | shouldBe (preprocess result) expected 503 | 504 | -- | Test the type at the given place. 505 | typeAt :: String -> (Int, Int, Int, Int, String) -> String -> Expectation 506 | typeAt a b c = do 507 | atFile ":type-at" "X.hs" a b id c 508 | 509 | -- | Test the type at the given place (with the given filename). 510 | atFile 511 | :: (Eq a, Show a) 512 | => String 513 | -> String 514 | -> String 515 | -> (Int, Int, Int, Int, String) 516 | -> (String -> a) 517 | -> a 518 | -> Expectation 519 | atFile cmd fname file (line,col,line',col',name) preprocess expected = do 520 | result <- 521 | withIntero 522 | [] 523 | (\dir repl -> do 524 | writeFile (dir ++ "/" ++ fname) file 525 | _ <- repl (":l " ++ show fname) 526 | repl 527 | (cmd ++ 528 | " " ++ 529 | (if any isSpace fname 530 | then show fname 531 | else fname) ++ 532 | " " ++ 533 | unwords (map show [line, col, line', col']) ++ 534 | (if null name 535 | then "" 536 | else " " ++ show name))) 537 | shouldBe (preprocess result) expected 538 | 539 | -- | Make a quick interaction with intero. 540 | eval :: String -- ^ Input. 541 | -> String -- ^ Expected output. 542 | -> Expectation 543 | eval send recv = do 544 | reply <- withIntero [] (\_ repl -> repl send) 545 | shouldBe (unlines (filter (not . null) (lines reply))) recv 546 | 547 | -- | Launch an interactive intero process. Creates a temporary 548 | -- directory in which the computation can work. 549 | withIntero 550 | :: MonadIO m 551 | => [String] -> (FilePath -> (String -> IO String) -> IO a) -> m a 552 | withIntero arguments cont = 553 | liftIO 554 | (withSystemTempDirectory 555 | "withIntero" 556 | (\dir -> do 557 | (inp,out,err,pid) <- 558 | catch 559 | (runInteractiveProcess 560 | "intero" 561 | ("-ignore-dot-ghci" : arguments) 562 | (Just dir) 563 | Nothing) 564 | (\(_ :: IOException) -> error "Couldn't launch intero process.") 565 | hSetBuffering inp NoBuffering 566 | hSetBuffering out NoBuffering 567 | hSetBuffering err NoBuffering 568 | let repl instr = do 569 | catch 570 | (do hPutStrLn inp instr 571 | let getReply = do 572 | mc <- 573 | catch 574 | (fmap Just (hGetChar out)) 575 | (\(_ :: IOException) -> return Nothing) 576 | case mc of 577 | Nothing -> hGetAvailable err 578 | Just '\4' -> hGetAvailable err 579 | Just c -> do 580 | cs <- getReply 581 | return (c : cs) 582 | getReply) 583 | (\(_ :: IOException) -> return "") 584 | _ <- repl ":set prompt \"\\4\"" 585 | finally 586 | (cont dir repl) 587 | (do ignored (hClose inp) 588 | ignored (hClose out) 589 | ignored (hClose err) 590 | ignored (terminateProcess pid)))) 591 | where 592 | ignored m = catch m (\(_ :: IOException) -> return ()) 593 | hGetAvailable h = do 594 | available <- catch (hReady h) (\(_ :: IOException) -> return False) 595 | if available 596 | then catch 597 | (do c <- hGetChar h 598 | cs <- hGetAvailable h 599 | return (c : cs)) 600 | (\(_ :: IOException) -> return []) 601 | else return [] 602 | 603 | -------------------------------------------------------------------------------- 604 | -- Spec combinators 605 | 606 | -- | Specify an issue that needs to be regression tested. 607 | issue 608 | :: Example a 609 | => String -> t -> a -> SpecWith (Arg a) 610 | issue label _link expectation = it label expectation 611 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-10.0 2 | 3 | nix: 4 | packages: [ ncurses clang ] 5 | -------------------------------------------------------------------------------- /test/test-ghcs: -------------------------------------------------------------------------------- 1 | set -e 2 | 3 | # Test GHC 8.6.5 4 | 5 | echo GHC 8.6.5 ... 6 | stack clean 7 | stack setup --resolver lts-13.20 8 | stack build . --resolver lts-13.20 --test --force-dirty --ghc-options=-fforce-recomp 9 | 10 | # Test GHC 8.4.1 11 | 12 | if [[ $TRAVIS_OS_NAME != 'linux' ]]; then 13 | 14 | echo "Skipping GHC 8.4.1 on OS X" 15 | 16 | else 17 | 18 | echo GHC 8.4.1 ... 19 | stack clean 20 | stack setup --resolver ghc-8.4.1 21 | stack build . --resolver ghc-8.4.1 --test --ghc-options=-Werror --force-dirty \ 22 | ghc-paths-0.1.0.9 network-2.6.3.4 random-1.1 syb-0.7 hspec-2.4.8 regex-compat-0.95.1 temporary-1.2.1.1 HUnit-1.6.0.0 QuickCheck-2.11.3 call-stack-0.1.0 exceptions-0.9.0 hspec-core-2.4.8 hspec-discover-2.4.8 hspec-expectations-0.8.2 regex-base-0.93.2 regex-posix-0.95.2 ansi-terminal-0.8.0.2 quickcheck-io-0.2.0 setenv-0.1.1.3 tf-random-0.5 transformers-compat-0.6.0.6 colour-2.3.4 primitive-0.6.3.0 23 | 24 | fi 25 | 26 | # Test GHC 8.2.2 27 | 28 | echo GHC 8.2.2 ... 29 | stack clean 30 | stack setup --resolver lts-10.0 31 | stack build . --resolver lts-10.0 --test --ghc-options=-Werror --force-dirty --ghc-options=-fforce-recomp 32 | 33 | # Test GHC 8.0.2 34 | 35 | echo GHC 8.0.2 ... 36 | stack clean 37 | stack setup --resolver lts-9.20 38 | stack build . --resolver lts-9.20 --test --ghc-options=-Werror --force-dirty --ghc-options=-fforce-recomp 39 | 40 | # Test GHC 8.0.1 41 | 42 | echo GHC 8.0.1 ... 43 | stack clean 44 | stack setup --resolver nightly-2016-05-27 45 | stack build --resolver nightly-2016-05-27 --test --ghc-options=-Werror --force-dirty --ghc-options=-fforce-recomp 46 | 47 | # Test GHC 7.10.3 48 | 49 | echo GHC 7.10.3 ... 50 | stack clean 51 | stack setup --resolver lts-4.1 52 | stack build --resolver lts-4.1 --test --ghc-options=-Werror --force-dirty --ghc-options=-fforce-recomp 53 | 54 | # Test GHC 7.10.2 55 | 56 | echo GHC 7.10.2 ... 57 | stack clean 58 | stack setup --resolver lts-3.0 59 | stack build --resolver lts-3.0 --test --ghc-options=-Werror --force-dirty --ghc-options=-fforce-recomp 60 | 61 | # Test GHC 7.8.4 62 | 63 | if [[ $TRAVIS_OS_NAME != 'linux' ]]; then 64 | 65 | echo "Skipping GHC 7.8.4 on OS X" 66 | 67 | else 68 | 69 | echo GHC 7.8.4 ... 70 | stack clean 71 | stack setup --resolver lts-1.0 72 | stack build --resolver lts-1.0 --test --ghc-options=-Werror --force-dirty --ghc-options=-fforce-recomp 73 | 74 | fi 75 | --------------------------------------------------------------------------------