diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,201 +1,201 @@ - Apache License - Version 2.0, January 2004 - http://www.apache.org/licenses/ - - TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION - - 1. Definitions. - - "License" shall mean the terms and conditions for use, reproduction, - and distribution as defined by Sections 1 through 9 of this document. - - "Licensor" shall mean the copyright owner or entity authorized by - the copyright owner that is granting the License. - - "Legal Entity" shall mean the union of the acting entity and all - other entities that control, are controlled by, or are under common - control with that entity. For the purposes of this definition, - "control" means (i) the power, direct or indirect, to cause the - direction or management of such entity, whether by contract or - otherwise, or (ii) ownership of fifty percent (50%) or more of the - outstanding shares, or (iii) beneficial ownership of such entity. - - "You" (or "Your") shall mean an individual or Legal Entity - exercising permissions granted by this License. - - "Source" form shall mean the preferred form for making modifications, - including but not limited to software source code, documentation - source, and configuration files. - - "Object" form shall mean any form resulting from mechanical - transformation or translation of a Source form, including but - not limited to compiled object code, generated documentation, - and conversions to other media types. - - "Work" shall mean the work of authorship, whether in Source or - Object form, made available under the License, as indicated by a - copyright notice that is included in or attached to the work - (an example is provided in the Appendix below). - - "Derivative Works" shall mean any work, whether in Source or Object - form, that is based on (or derived from) the Work and for which the - editorial revisions, annotations, elaborations, or other modifications - represent, as a whole, an original work of authorship. For the purposes - of this License, Derivative Works shall not include works that remain - separable from, or merely link (or bind by name) to the interfaces of, - the Work and Derivative Works thereof. - - "Contribution" shall mean any work of authorship, including - the original version of the Work and any modifications or additions - to that Work or Derivative Works thereof, that is intentionally - submitted to Licensor for inclusion in the Work by the copyright owner - or by an individual or Legal Entity authorized to submit on behalf of - the copyright owner. For the purposes of this definition, "submitted" - means any form of electronic, verbal, or written communication sent - to the Licensor or its representatives, including but not limited to - communication on electronic mailing lists, source code control systems, - and issue tracking systems that are managed by, or on behalf of, the - Licensor for the purpose of discussing and improving the Work, but - excluding communication that is conspicuously marked or otherwise - designated in writing by the copyright owner as "Not a Contribution." - - "Contributor" shall mean Licensor and any individual or Legal Entity - on behalf of whom a Contribution has been received by Licensor and - subsequently incorporated within the Work. - - 2. Grant of Copyright License. Subject to the terms and conditions of - this License, each Contributor hereby grants to You a perpetual, - worldwide, non-exclusive, no-charge, royalty-free, irrevocable - copyright license to reproduce, prepare Derivative Works of, - publicly display, publicly perform, sublicense, and distribute the - Work and such Derivative Works in Source or Object form. - - 3. Grant of Patent License. Subject to the terms and conditions of - this License, each Contributor hereby grants to You a perpetual, - worldwide, non-exclusive, no-charge, royalty-free, irrevocable - (except as stated in this section) patent license to make, have made, - use, offer to sell, sell, import, and otherwise transfer the Work, - where such license applies only to those patent claims licensable - by such Contributor that are necessarily infringed by their - Contribution(s) alone or by combination of their Contribution(s) - with the Work to which such Contribution(s) was submitted. If You - institute patent litigation against any entity (including a - cross-claim or counterclaim in a lawsuit) alleging that the Work - or a Contribution incorporated within the Work constitutes direct - or contributory patent infringement, then any patent licenses - granted to You under this License for that Work shall terminate - as of the date such litigation is filed. - - 4. Redistribution. You may reproduce and distribute copies of the - Work or Derivative Works thereof in any medium, with or without - modifications, and in Source or Object form, provided that You - meet the following conditions: - - (a) You must give any other recipients of the Work or - Derivative Works a copy of this License; and - - (b) You must cause any modified files to carry prominent notices - stating that You changed the files; and - - (c) You must retain, in the Source form of any Derivative Works - that You distribute, all copyright, patent, trademark, and - attribution notices from the Source form of the Work, - excluding those notices that do not pertain to any part of - the Derivative Works; and - - (d) If the Work includes a "NOTICE" text file as part of its - distribution, then any Derivative Works that You distribute must - include a readable copy of the attribution notices contained - within such NOTICE file, excluding those notices that do not - pertain to any part of the Derivative Works, in at least one - of the following places: within a NOTICE text file distributed - as part of the Derivative Works; within the Source form or - documentation, if provided along with the Derivative Works; or, - within a display generated by the Derivative Works, if and - wherever such third-party notices normally appear. The contents - of the NOTICE file are for informational purposes only and - do not modify the License. You may add Your own attribution - notices within Derivative Works that You distribute, alongside - or as an addendum to the NOTICE text from the Work, provided - that such additional attribution notices cannot be construed - as modifying the License. - - You may add Your own copyright statement to Your modifications and - may provide additional or different license terms and conditions - for use, reproduction, or distribution of Your modifications, or - for any such Derivative Works as a whole, provided Your use, - reproduction, and distribution of the Work otherwise complies with - the conditions stated in this License. - - 5. Submission of Contributions. Unless You explicitly state otherwise, - any Contribution intentionally submitted for inclusion in the Work - by You to the Licensor shall be under the terms and conditions of - this License, without any additional terms or conditions. - Notwithstanding the above, nothing herein shall supersede or modify - the terms of any separate license agreement you may have executed - with Licensor regarding such Contributions. - - 6. Trademarks. This License does not grant permission to use the trade - names, trademarks, service marks, or product names of the Licensor, - except as required for reasonable and customary use in describing the - origin of the Work and reproducing the content of the NOTICE file. - - 7. Disclaimer of Warranty. Unless required by applicable law or - agreed to in writing, Licensor provides the Work (and each - Contributor provides its Contributions) on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or - implied, including, without limitation, any warranties or conditions - of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A - PARTICULAR PURPOSE. You are solely responsible for determining the - appropriateness of using or redistributing the Work and assume any - risks associated with Your exercise of permissions under this License. - - 8. Limitation of Liability. In no event and under no legal theory, - whether in tort (including negligence), contract, or otherwise, - unless required by applicable law (such as deliberate and grossly - negligent acts) or agreed to in writing, shall any Contributor be - liable to You for damages, including any direct, indirect, special, - incidental, or consequential damages of any character arising as a - result of this License or out of the use or inability to use the - Work (including but not limited to damages for loss of goodwill, - work stoppage, computer failure or malfunction, or any and all - other commercial damages or losses), even if such Contributor - has been advised of the possibility of such damages. - - 9. Accepting Warranty or Additional Liability. While redistributing - the Work or Derivative Works thereof, You may choose to offer, - and charge a fee for, acceptance of support, warranty, indemnity, - or other liability obligations and/or rights consistent with this - License. However, in accepting such obligations, You may act only - on Your own behalf and on Your sole responsibility, not on behalf - of any other Contributor, and only if You agree to indemnify, - defend, and hold each Contributor harmless for any liability - incurred by, or claims asserted against, such Contributor by reason - of your accepting any such warranty or additional liability. - - END OF TERMS AND CONDITIONS - - APPENDIX: How to apply the Apache License to your work. - - To apply the Apache License to your work, attach the following - boilerplate notice, with the fields enclosed by brackets "[]" - replaced with your own identifying information. (Don't include - the brackets!) The text should be enclosed in the appropriate - comment syntax for the file format. We also recommend that a - file or class name and description of purpose be included on the - same "printed page" as the copyright notice for easier - identification within third-party archives. - - Copyright [yyyy] [name of copyright owner] - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. + Apache License + Version 2.0, January 2004 + http://www.apache.org/licenses/ + + TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION + + 1. Definitions. + + "License" shall mean the terms and conditions for use, reproduction, + and distribution as defined by Sections 1 through 9 of this document. + + "Licensor" shall mean the copyright owner or entity authorized by + the copyright owner that is granting the License. + + "Legal Entity" shall mean the union of the acting entity and all + other entities that control, are controlled by, or are under common + control with that entity. For the purposes of this definition, + "control" means (i) the power, direct or indirect, to cause the + direction or management of such entity, whether by contract or + otherwise, or (ii) ownership of fifty percent (50%) or more of the + outstanding shares, or (iii) beneficial ownership of such entity. + + "You" (or "Your") shall mean an individual or Legal Entity + exercising permissions granted by this License. + + "Source" form shall mean the preferred form for making modifications, + including but not limited to software source code, documentation + source, and configuration files. + + "Object" form shall mean any form resulting from mechanical + transformation or translation of a Source form, including but + not limited to compiled object code, generated documentation, + and conversions to other media types. + + "Work" shall mean the work of authorship, whether in Source or + Object form, made available under the License, as indicated by a + copyright notice that is included in or attached to the work + (an example is provided in the Appendix below). + + "Derivative Works" shall mean any work, whether in Source or Object + form, that is based on (or derived from) the Work and for which the + editorial revisions, annotations, elaborations, or other modifications + represent, as a whole, an original work of authorship. For the purposes + of this License, Derivative Works shall not include works that remain + separable from, or merely link (or bind by name) to the interfaces of, + the Work and Derivative Works thereof. + + "Contribution" shall mean any work of authorship, including + the original version of the Work and any modifications or additions + to that Work or Derivative Works thereof, that is intentionally + submitted to Licensor for inclusion in the Work by the copyright owner + or by an individual or Legal Entity authorized to submit on behalf of + the copyright owner. For the purposes of this definition, "submitted" + means any form of electronic, verbal, or written communication sent + to the Licensor or its representatives, including but not limited to + communication on electronic mailing lists, source code control systems, + and issue tracking systems that are managed by, or on behalf of, the + Licensor for the purpose of discussing and improving the Work, but + excluding communication that is conspicuously marked or otherwise + designated in writing by the copyright owner as "Not a Contribution." + + "Contributor" shall mean Licensor and any individual or Legal Entity + on behalf of whom a Contribution has been received by Licensor and + subsequently incorporated within the Work. + + 2. Grant of Copyright License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + copyright license to reproduce, prepare Derivative Works of, + publicly display, publicly perform, sublicense, and distribute the + Work and such Derivative Works in Source or Object form. + + 3. Grant of Patent License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + (except as stated in this section) patent license to make, have made, + use, offer to sell, sell, import, and otherwise transfer the Work, + where such license applies only to those patent claims licensable + by such Contributor that are necessarily infringed by their + Contribution(s) alone or by combination of their Contribution(s) + with the Work to which such Contribution(s) was submitted. If You + institute patent litigation against any entity (including a + cross-claim or counterclaim in a lawsuit) alleging that the Work + or a Contribution incorporated within the Work constitutes direct + or contributory patent infringement, then any patent licenses + granted to You under this License for that Work shall terminate + as of the date such litigation is filed. + + 4. Redistribution. You may reproduce and distribute copies of the + Work or Derivative Works thereof in any medium, with or without + modifications, and in Source or Object form, provided that You + meet the following conditions: + + (a) You must give any other recipients of the Work or + Derivative Works a copy of this License; and + + (b) You must cause any modified files to carry prominent notices + stating that You changed the files; and + + (c) You must retain, in the Source form of any Derivative Works + that You distribute, all copyright, patent, trademark, and + attribution notices from the Source form of the Work, + excluding those notices that do not pertain to any part of + the Derivative Works; and + + (d) If the Work includes a "NOTICE" text file as part of its + distribution, then any Derivative Works that You distribute must + include a readable copy of the attribution notices contained + within such NOTICE file, excluding those notices that do not + pertain to any part of the Derivative Works, in at least one + of the following places: within a NOTICE text file distributed + as part of the Derivative Works; within the Source form or + documentation, if provided along with the Derivative Works; or, + within a display generated by the Derivative Works, if and + wherever such third-party notices normally appear. The contents + of the NOTICE file are for informational purposes only and + do not modify the License. You may add Your own attribution + notices within Derivative Works that You distribute, alongside + or as an addendum to the NOTICE text from the Work, provided + that such additional attribution notices cannot be construed + as modifying the License. + + You may add Your own copyright statement to Your modifications and + may provide additional or different license terms and conditions + for use, reproduction, or distribution of Your modifications, or + for any such Derivative Works as a whole, provided Your use, + reproduction, and distribution of the Work otherwise complies with + the conditions stated in this License. + + 5. Submission of Contributions. Unless You explicitly state otherwise, + any Contribution intentionally submitted for inclusion in the Work + by You to the Licensor shall be under the terms and conditions of + this License, without any additional terms or conditions. + Notwithstanding the above, nothing herein shall supersede or modify + the terms of any separate license agreement you may have executed + with Licensor regarding such Contributions. + + 6. Trademarks. This License does not grant permission to use the trade + names, trademarks, service marks, or product names of the Licensor, + except as required for reasonable and customary use in describing the + origin of the Work and reproducing the content of the NOTICE file. + + 7. Disclaimer of Warranty. Unless required by applicable law or + agreed to in writing, Licensor provides the Work (and each + Contributor provides its Contributions) on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or + implied, including, without limitation, any warranties or conditions + of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A + PARTICULAR PURPOSE. You are solely responsible for determining the + appropriateness of using or redistributing the Work and assume any + risks associated with Your exercise of permissions under this License. + + 8. Limitation of Liability. In no event and under no legal theory, + whether in tort (including negligence), contract, or otherwise, + unless required by applicable law (such as deliberate and grossly + negligent acts) or agreed to in writing, shall any Contributor be + liable to You for damages, including any direct, indirect, special, + incidental, or consequential damages of any character arising as a + result of this License or out of the use or inability to use the + Work (including but not limited to damages for loss of goodwill, + work stoppage, computer failure or malfunction, or any and all + other commercial damages or losses), even if such Contributor + has been advised of the possibility of such damages. + + 9. Accepting Warranty or Additional Liability. While redistributing + the Work or Derivative Works thereof, You may choose to offer, + and charge a fee for, acceptance of support, warranty, indemnity, + or other liability obligations and/or rights consistent with this + License. However, in accepting such obligations, You may act only + on Your own behalf and on Your sole responsibility, not on behalf + of any other Contributor, and only if You agree to indemnify, + defend, and hold each Contributor harmless for any liability + incurred by, or claims asserted against, such Contributor by reason + of your accepting any such warranty or additional liability. + + END OF TERMS AND CONDITIONS + + APPENDIX: How to apply the Apache License to your work. + + To apply the Apache License to your work, attach the following + boilerplate notice, with the fields enclosed by brackets "[]" + replaced with your own identifying information. (Don't include + the brackets!) The text should be enclosed in the appropriate + comment syntax for the file format. We also recommend that a + file or class name and description of purpose be included on the + same "printed page" as the copyright notice for easier + identification within third-party archives. + + Copyright [yyyy] [name of copyright owner] + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,332 +1,332 @@ -# Eval plugin for the [Haskell Language Server](https://github.com/haskell/haskell-language-server#readme) - -The Eval plugin evaluates code inserted in comments. - -This is mainly useful to test and document functions and to quickly evaluate small expressions. - -Every line of code to be evaluated is introduced by __>>>__ - -A quick calculation: - -``` --- >>> 2**4.5/pi --- 7.202530529256849 -``` - -A little test for the `double` function: - -``` -{- | -A doubling function. - ->>> double 11 -22 --} -double = (2*) -``` - -# Demo - -![Eval](demo.gif) - -# Test Structure - -A test is composed by a sequence of contiguous lines, the result of their evaluation is inserted after the test body: - -``` ->>> "AB" ++ "CD" ->>> "CD" ++ "AB" -"ABCD" -"CDAB" -``` - -You execute a test by clicking on the _Evaluate_ code lens that appears above it (or _Refresh_, if the test has been run previously). - -All tests in the same comment block are executed together. - - -Tests can appear in all kind of comments: -* plain comments (both single and multi line) -``` -{- ->>> "ab" ++ "c" -"abc" --} - --- >>> "ab" ++ "c" --- "abc" -``` -* Haddock commands (both single and multi line, forward and backward) -``` -{- ->>> "ab" ++ "c" -"abc" --} - --- >>> "ab" ++ "c" --- "abc" - -double a = a + a --- ^ A doubling function --- >>> double 11 --- 22 -``` - -Modules that use CPP and Literate Haskell (Bird-style only) modules are also supported (for GHC >= 8.8). - -# Test Components - -In general, a test is a sequence of: -* imports -* directives -* statements -* expressions -* properties - -in no particular order, with every line introduced by __>>>__ (or __prop>__ in the case of properties). - -### Imports - -``` ->>> import Data.List ->>> import GHC.TypeNats -``` - -From any package in scope but currently NOT from modules in the same source directory. - -### Language Extensions - -``` ->>> :set -XScopedTypeVariables -XStandaloneDeriving -XDataKinds -XTypeOperators -XExplicitNamespaces -``` - -### Statements and Declarations - -Function declarations (optionally introduced by __let__): - -``` ->>> let tuple x = (x,x) ->>> let one=1;two=2 ->>> triple x = (x,x,x) -``` - -Any other declaration: - -``` ->>> data TertiumDatur = Truly | Falsely | Other deriving Show ->>> class Display a where display :: a -> String ->>> instance Display TertiumDatur where display = show -``` - -Definitions are available to following tests in the __same__ comment: - -``` -{- ->>> two = 2 - ->>> two -2 --} - --- >>> two --- Variable not in scope: two -``` - -If you want definitions to be available to all tests in the module, define a setup section: - -``` --- $setup --- >>> eleven = 11 - -{- -eleven is now available to any test: - ->>> eleven*2 -22 --} -``` - - -### Type and Kind directives - -``` ->>> :type Truly -Truly :: TertiumDatur - ->>> :kind TertiumDatur -TertiumDatur :: * - ->>> :type 3 -3 :: forall p. Num p => p - ->>> :type +d 3 -3 :: Integer - ->>> type N = 1 ->>> type M = 40 ->>> :kind! N + M + 1 -N + M + 1 :: Nat -= 42 -``` - -### Expressions - -``` ->>> tuple 2 ->>> triple 3 ->>> display Other -(2,2) -(3,3,3) -"Other" -``` - -IO expressions can also be evaluated but their output to stdout/stderr is NOT captured: - -``` ->>> print "foo" -() -``` - -### Properties - -``` -prop> \(l::[Int]) -> reverse (reverse l) == l -+++ OK, passed 100 tests. -``` - -# Haddock vs Plain Comments - -There is a conceptual difference between Haddock and plain comments: -* Haddock comments constitute the external module's documentation, they state the contract between the implementor and the module users (API) -* Plain comments are internal documentation meant to explain how the code works (implementation). - -This conceptual difference is reflected in the way tests results are refreshed by the Eval plugin. - -Say that we have defined a `double` function as: - -``` -double = (*2) -``` - -And, in an Haddock comment, we run the test: - -``` -{- | ->>> double 11 -22 --} -``` - -We then change the definition to: - -``` -double = (*3) -``` - -When we refresh the test, its current result is compared with the previous one and differences are displayed (as they change the API): - -``` -{- | ->>> double 11 -WAS 22 -NOW 33 --} -``` - -On the contrary, if the test were into a plain comment, the result would simply be replaced: - -``` -{- ->>> double 11 -33 --} -``` - -# Multiline Output - -By default, the output of every expression is returned as a single line. - -This is a problem if you want, for example, to pretty print a value (in this case using the [pretty-simple](https://hackage.haskell.org/package/pretty-simple) package): - -``` ->>> import Text.Pretty.Simple ->>> pShowNoColor [1..3] -"[ 1\n, 2\n, 3\n]" -``` - -We could try to print the pretty-print output, but stdout is not captured so we get just a (): - -``` ->>> print $ pShowNoColor [1..7] -() -``` - -To display it properly, we can exploit the fact that the output of an error is displayed as a multi-line text: - -``` ->>> import qualified Data.Text.Lazy as TL ->>> import Text.Pretty.Simple ->>> prettyPrint v = error (TL.unpack $ pShowNoColor v) :: IO String ->>> prettyPrint [1..3] -[ 1 -, 2 -, 3 -] -``` - -# Differences with doctest - -Though the Eval plugin functionality is quite similar to that of [doctest](https://hackage.haskell.org/package/doctest), some doctest's features are not supported. - -### Capturing Stdout - -Only the value of an IO expression is spliced in, not its output: - -``` ->>> print "foo" -() -``` - -### Pattern Matching - -The arbitrary content matcher __...__ is unsupported. - -### Missing lambda abstractions in property tests - -Variables are not automatically introduced: - -``` -prop> reverse (reverse l) == (l::[Int]) -Variable not in scope: l :: [Int] -``` - -This works: - -``` -prop> \(l::[Int]) -> reverse (reverse l) == l -+++ OK, passed 100 tests. -``` - -### Multiline Expressions - -``` - >>> :{ - let - x = 1 - y = 2 - in x + y + multiline - :} -``` - -# Acknowledgments - -Design/features derived from: - -* [GHCi](https://downloads.haskell.org/~ghc/latest/docs/html/users_guide/ghci.html) - -* [Haddock's](https://www.haskell.org/haddock/doc/html/ch03s08.html#idm140354810775744) Examples and Properties - -* [Doctest](https://hackage.haskell.org/package/doctest) - -* the REPLoid feature of [Dante](https://github.com/jyp/dante) - +# Eval plugin for the [Haskell Language Server](https://github.com/haskell/haskell-language-server#readme) + +The Eval plugin evaluates code inserted in comments. + +This is mainly useful to test and document functions and to quickly evaluate small expressions. + +Every line of code to be evaluated is introduced by __>>>__ + +A quick calculation: + +``` +-- >>> 2**4.5/pi +-- 7.202530529256849 +``` + +A little test for the `double` function: + +``` +{- | +A doubling function. + +>>> double 11 +22 +-} +double = (2*) +``` + +# Demo + +![Eval](demo.gif) + +# Test Structure + +A test is composed by a sequence of contiguous lines, the result of their evaluation is inserted after the test body: + +``` +>>> "AB" ++ "CD" +>>> "CD" ++ "AB" +"ABCD" +"CDAB" +``` + +You execute a test by clicking on the _Evaluate_ code lens that appears above it (or _Refresh_, if the test has been run previously). + +All tests in the same comment block are executed together. + + +Tests can appear in all kind of comments: +* plain comments (both single and multi line) +``` +{- +>>> "ab" ++ "c" +"abc" +-} + +-- >>> "ab" ++ "c" +-- "abc" +``` +* Haddock commands (both single and multi line, forward and backward) +``` +{- +>>> "ab" ++ "c" +"abc" +-} + +-- >>> "ab" ++ "c" +-- "abc" + +double a = a + a +-- ^ A doubling function +-- >>> double 11 +-- 22 +``` + +Modules that use CPP and Literate Haskell (Bird-style only) modules are also supported (for GHC >= 8.8). + +# Test Components + +In general, a test is a sequence of: +* imports +* directives +* statements +* expressions +* properties + +in no particular order, with every line introduced by __>>>__ (or __prop>__ in the case of properties). + +### Imports + +``` +>>> import Data.List +>>> import GHC.TypeNats +``` + +From any package in scope but currently NOT from modules in the same source directory. + +### Language Extensions + +``` +>>> :set -XScopedTypeVariables -XStandaloneDeriving -XDataKinds -XTypeOperators -XExplicitNamespaces +``` + +### Statements and Declarations + +Function declarations (optionally introduced by __let__): + +``` +>>> let tuple x = (x,x) +>>> let one=1;two=2 +>>> triple x = (x,x,x) +``` + +Any other declaration: + +``` +>>> data TertiumDatur = Truly | Falsely | Other deriving Show +>>> class Display a where display :: a -> String +>>> instance Display TertiumDatur where display = show +``` + +Definitions are available to following tests in the __same__ comment: + +``` +{- +>>> two = 2 + +>>> two +2 +-} + +-- >>> two +-- Variable not in scope: two +``` + +If you want definitions to be available to all tests in the module, define a setup section: + +``` +-- $setup +-- >>> eleven = 11 + +{- +eleven is now available to any test: + +>>> eleven*2 +22 +-} +``` + + +### Type and Kind directives + +``` +>>> :type Truly +Truly :: TertiumDatur + +>>> :kind TertiumDatur +TertiumDatur :: * + +>>> :type 3 +3 :: forall p. Num p => p + +>>> :type +d 3 +3 :: Integer + +>>> type N = 1 +>>> type M = 40 +>>> :kind! N + M + 1 +N + M + 1 :: Nat += 42 +``` + +### Expressions + +``` +>>> tuple 2 +>>> triple 3 +>>> display Other +(2,2) +(3,3,3) +"Other" +``` + +IO expressions can also be evaluated but their output to stdout/stderr is NOT captured: + +``` +>>> print "foo" +() +``` + +### Properties + +``` +prop> \(l::[Int]) -> reverse (reverse l) == l ++++ OK, passed 100 tests. +``` + +# Haddock vs Plain Comments + +There is a conceptual difference between Haddock and plain comments: +* Haddock comments constitute the external module's documentation, they state the contract between the implementor and the module users (API) +* Plain comments are internal documentation meant to explain how the code works (implementation). + +This conceptual difference is reflected in the way tests results are refreshed by the Eval plugin. + +Say that we have defined a `double` function as: + +``` +double = (*2) +``` + +And, in an Haddock comment, we run the test: + +``` +{- | +>>> double 11 +22 +-} +``` + +We then change the definition to: + +``` +double = (*3) +``` + +When we refresh the test, its current result is compared with the previous one and differences are displayed (as they change the API): + +``` +{- | +>>> double 11 +WAS 22 +NOW 33 +-} +``` + +On the contrary, if the test were into a plain comment, the result would simply be replaced: + +``` +{- +>>> double 11 +33 +-} +``` + +# Multiline Output + +By default, the output of every expression is returned as a single line. + +This is a problem if you want, for example, to pretty print a value (in this case using the [pretty-simple](https://hackage.haskell.org/package/pretty-simple) package): + +``` +>>> import Text.Pretty.Simple +>>> pShowNoColor [1..3] +"[ 1\n, 2\n, 3\n]" +``` + +We could try to print the pretty-print output, but stdout is not captured so we get just a (): + +``` +>>> print $ pShowNoColor [1..7] +() +``` + +To display it properly, we can exploit the fact that the output of an error is displayed as a multi-line text: + +``` +>>> import qualified Data.Text.Lazy as TL +>>> import Text.Pretty.Simple +>>> prettyPrint v = error (TL.unpack $ pShowNoColor v) :: IO String +>>> prettyPrint [1..3] +[ 1 +, 2 +, 3 +] +``` + +# Differences with doctest + +Though the Eval plugin functionality is quite similar to that of [doctest](https://hackage.haskell.org/package/doctest), some doctest's features are not supported. + +### Capturing Stdout + +Only the value of an IO expression is spliced in, not its output: + +``` +>>> print "foo" +() +``` + +### Pattern Matching + +The arbitrary content matcher __...__ is unsupported. + +### Missing lambda abstractions in property tests + +Variables are not automatically introduced: + +``` +prop> reverse (reverse l) == (l::[Int]) +Variable not in scope: l :: [Int] +``` + +This works: + +``` +prop> \(l::[Int]) -> reverse (reverse l) == l ++++ OK, passed 100 tests. +``` + +### Multiline Expressions + +``` + >>> :{ + let + x = 1 + y = 2 + in x + y + multiline + :} +``` + +# Acknowledgments + +Design/features derived from: + +* [GHCi](https://downloads.haskell.org/~ghc/latest/docs/html/users_guide/ghci.html) + +* [Haddock's](https://www.haskell.org/haddock/doc/html/ch03s08.html#idm140354810775744) Examples and Properties + +* [Doctest](https://hackage.haskell.org/package/doctest) + +* the REPLoid feature of [Dante](https://github.com/jyp/dante) + diff --git a/hls-eval-plugin.cabal b/hls-eval-plugin.cabal --- a/hls-eval-plugin.cabal +++ b/hls-eval-plugin.cabal @@ -1,78 +1,112 @@ -cabal-version: 2.2 -name: hls-eval-plugin -version: 1.0.0.0 -synopsis: Eval plugin for Haskell Language Server -description: Please see the README on GitHub at -category: Development -bug-reports: https://github.com/haskell/haskell-language-server/issues -license: Apache-2.0 -license-file: LICENSE -author: https://github.com/haskell/haskell-language-server/contributors -maintainer: https://github.com/haskell/haskell-language-server/contributors - -build-type: Simple -extra-source-files: - LICENSE - README.md - -flag pedantic - description: Enable -Werror - default: False - manual: True - -source-repository head - type: git - location: https://github.com/haskell/haskell-language-server - -library - exposed-modules: Ide.Plugin.Eval - hs-source-dirs: src - other-modules: - Ide.Plugin.Eval.Code - Ide.Plugin.Eval.CodeLens - Ide.Plugin.Eval.GHC - Ide.Plugin.Eval.Parse.Comments - Ide.Plugin.Eval.Parse.Option - Ide.Plugin.Eval.Types - Ide.Plugin.Eval.Util - - build-depends: - , aeson - , base >=4.12 && <5 - , containers - , deepseq - , Diff - , directory - , dlist - , extra - , filepath - , ghc - , ghc-boot-th - , ghc-paths - , ghcide ^>= 1.0.0.0 - , hashable - , lsp - , lsp-types - , hls-plugin-api ^>= 1.0.0.0 - , lens - , megaparsec >=0.9 - , mtl - , parser-combinators - , pretty-simple - , QuickCheck - , safe-exceptions - , shake - , temporary - , text - , time - , transformers - , unordered-containers - , unliftio - - ghc-options: -Wall -Wno-name-shadowing -Wno-unticked-promoted-constructors - - if flag(pedantic) - ghc-options: -Werror - - default-language: Haskell2010 - default-extensions: DataKinds, TypeOperators +cabal-version: 2.4 +name: hls-eval-plugin +version: 1.1.0.0 +synopsis: Eval plugin for Haskell Language Server +description: + Please see the README on GitHub at + +category: Development +bug-reports: https://github.com/haskell/haskell-language-server/issues +license: Apache-2.0 +license-file: LICENSE +author: + https://github.com/haskell/haskell-language-server/contributors + +maintainer: + https://github.com/haskell/haskell-language-server/contributors + +build-type: Simple +extra-source-files: + LICENSE + README.md + test/testdata/*.cabal + test/testdata/*.expected + test/testdata/*.hs + test/testdata/*.lhs + test/testdata/*.yaml + +flag pedantic + description: Enable -Werror + default: False + manual: True + +source-repository head + type: git + location: https://github.com/haskell/haskell-language-server + +library + exposed-modules: + Ide.Plugin.Eval + Ide.Plugin.Eval.Types + + hs-source-dirs: src + other-modules: + Ide.Plugin.Eval.Code + Ide.Plugin.Eval.CodeLens + Ide.Plugin.Eval.GHC + Ide.Plugin.Eval.Parse.Comments + Ide.Plugin.Eval.Parse.Option + Ide.Plugin.Eval.Util + + build-depends: + , aeson + , base >=4.12 && <5 + , containers + , deepseq + , Diff ^>=0.4.0 + , directory + , dlist + , extra + , filepath + , ghc + , ghc-boot-th + , ghc-paths + , ghcide ^>=1.2 + , hashable + , hls-plugin-api ^>=1.1 + , lens + , lsp + , lsp-types + , megaparsec >=9.0 + , mtl + , parser-combinators + , pretty-simple + , QuickCheck + , safe-exceptions + , shake + , temporary + , text + , time + , transformers + , unliftio + , unordered-containers + + ghc-options: + -Wall -Wno-name-shadowing -Wno-unticked-promoted-constructors + + if flag(pedantic) + ghc-options: -Werror + + default-language: Haskell2010 + default-extensions: + DataKinds + TypeOperators + +test-suite tests + type: exitcode-stdio-1.0 + default-language: Haskell2010 + hs-source-dirs: test + main-is: Main.hs + ghc-options: -threaded -rtsopts -with-rtsopts=-N + build-depends: + , aeson + , base + , directory + , extra + , filepath + , hls-eval-plugin + , hls-test-utils ^>=1.0 + , lens + , lsp-test + , lsp-types + , text diff --git a/src/Ide/Plugin/Eval.hs b/src/Ide/Plugin/Eval.hs --- a/src/Ide/Plugin/Eval.hs +++ b/src/Ide/Plugin/Eval.hs @@ -1,28 +1,28 @@ -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# OPTIONS_GHC -Wwarn #-} - -{- | -Eval Plugin entry point. --} -module Ide.Plugin.Eval ( - descriptor, -) where - -import Development.IDE (IdeState) -import qualified Ide.Plugin.Eval.CodeLens as CL -import Ide.Types ( - PluginDescriptor (..), - PluginId, - defaultPluginDescriptor, - mkPluginHandler - ) -import Language.LSP.Types - --- |Plugin descriptor -descriptor :: PluginId -> PluginDescriptor IdeState -descriptor plId = - (defaultPluginDescriptor plId) - { pluginHandlers = mkPluginHandler STextDocumentCodeLens CL.codeLens - , pluginCommands = [CL.evalCommand] - } +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -Wwarn #-} + +{- | +Eval Plugin entry point. +-} +module Ide.Plugin.Eval ( + descriptor, +) where + +import Development.IDE (IdeState) +import qualified Ide.Plugin.Eval.CodeLens as CL +import Ide.Types ( + PluginDescriptor (..), + PluginId, + defaultPluginDescriptor, + mkPluginHandler + ) +import Language.LSP.Types + +-- |Plugin descriptor +descriptor :: PluginId -> PluginDescriptor IdeState +descriptor plId = + (defaultPluginDescriptor plId) + { pluginHandlers = mkPluginHandler STextDocumentCodeLens CL.codeLens + , pluginCommands = [CL.evalCommand] + } diff --git a/src/Ide/Plugin/Eval/Code.hs b/src/Ide/Plugin/Eval/Code.hs --- a/src/Ide/Plugin/Eval/Code.hs +++ b/src/Ide/Plugin/Eval/Code.hs @@ -1,127 +1,131 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# OPTIONS_GHC -Wwarn -fno-warn-orphans #-} - --- | Expression execution -module Ide.Plugin.Eval.Code (Statement, testRanges, resultRange, evalExtensions, evalSetup, evalExpr, propSetup, testCheck, asStatements) where - -import Data.Algorithm.Diff (Diff, PolyDiff (..), getDiff) -import qualified Data.List.NonEmpty as NE -import Data.String (IsString) -import qualified Data.Text as T -import Development.IDE.Types.Location (Position (..), Range (..)) -import GHC (compileExpr) -import GHC.LanguageExtensions.Type (Extension (..)) -import GhcMonad (Ghc, GhcMonad, liftIO) -import Ide.Plugin.Eval.Types ( - Language (Plain), - Loc, - Section (sectionLanguage), - Test (..), - Txt, - locate, - locate0, Located(..) - ) -import InteractiveEval (runDecls) -import Unsafe.Coerce (unsafeCoerce) -import Control.Lens ((^.)) -import Language.LSP.Types.Lens (start, line) - --- | Return the ranges of the expression and result parts of the given test -testRanges :: Test -> (Range, Range) -testRanges tst = - let startLine = testRange tst ^. start.line - (exprLines, resultLines) = testLenghts tst - resLine = startLine + exprLines - in ( Range - (Position startLine 0) - --(Position (startLine + exprLines + resultLines) 0), - (Position resLine 0) - , Range (Position resLine 0) (Position (resLine + resultLines) 0) - ) - -{- |The document range where a test is defined - testRange :: Loc Test -> Range - testRange = fst . testRanges --} - --- |The document range where the result of the test is defined -resultRange :: Test -> Range -resultRange = snd . testRanges - --- TODO: handle BLANKLINE -{- ->>> showDiffs $ getDiff ["abc","def","ghi","end"] ["abc","def","Z","ZZ","end"] -["abc","def","WAS ghi","NOW Z","NOW ZZ","end"] --} -showDiffs :: (Semigroup a, IsString a) => [Diff a] -> [a] -showDiffs = map showDiff - -showDiff :: (Semigroup a, IsString a) => Diff a -> a -showDiff (First w) = "WAS " <> w -showDiff (Second w) = "NOW " <> w -showDiff (Both w _) = w - -testCheck :: (Section, Test) -> [T.Text] -> [T.Text] -testCheck (section, test) out - | null (testOutput test) || sectionLanguage section == Plain = out - | otherwise = showDiffs $ getDiff (map T.pack $ testOutput test) out - -testLenghts :: Test -> (Int, Int) -testLenghts (Example e r _) = (NE.length e, length r) -testLenghts (Property _ r _) = (1, length r) - --- |A one-line Haskell statement -type Statement = Loc String - -asStatements :: Test -> [Statement] -asStatements lt = locate $ Located (testRange lt ^. start.line) (asStmts lt) - -asStmts :: Test -> [Txt] -asStmts (Example e _ _) = NE.toList e -asStmts (Property t _ _) = - ["prop11 = " ++ t, "(propEvaluation prop11 :: IO String)"] - --- |Evaluate an expression (either a pure expression or an IO a) -evalExpr :: GhcMonad m => [Char] -> m String -evalExpr e = do - res <- compileExpr $ "asPrint (" ++ e ++ ")" - liftIO (unsafeCoerce res :: IO String) - --- |GHC extensions required for expression evaluation -evalExtensions :: [Extension] -evalExtensions = - [ OverlappingInstances - , UndecidableInstances - , FlexibleInstances - , IncoherentInstances - , TupleSections - ] - --- |GHC declarations required for expression evaluation -evalSetup :: Ghc () -evalSetup = - mapM_ - runDecls - [ "class Print f where asPrint :: f -> IO String" - , "instance Show a => Print (IO a) where asPrint io = io >>= return . show" - , "instance Show a => Print a where asPrint a = return (show a)" - ] - -{- |GHC declarations required to execute test properties - -Example: - -prop> \(l::[Bool]) -> reverse (reverse l) == l -+++ OK, passed 100 tests. - -prop> \(l::[Bool]) -> reverse l == l -*** Failed! Falsified (after 6 tests and 2 shrinks): -[True,False] --} -propSetup :: [Loc [Char]] -propSetup = - locate0 - [ ":set -XScopedTypeVariables -XExplicitForAll" - , "import qualified Test.QuickCheck as Q11" - , "propEvaluation p = Q11.quickCheckWithResult Q11.stdArgs p >>= error . Q11.output" -- uses `error` to get a multi-line display - ] +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -Wwarn -fno-warn-orphans #-} + +-- | Expression execution +module Ide.Plugin.Eval.Code (Statement, testRanges, resultRange, evalExtensions, evalSetup, propSetup, testCheck, asStatements,myExecStmt) where + +import Control.Lens ((^.)) +import Data.Algorithm.Diff (Diff, PolyDiff (..), getDiff) +import qualified Data.List.NonEmpty as NE +import Data.String (IsString) +import qualified Data.Text as T +import Development.IDE.Types.Location (Position (..), Range (..)) +import GHC (ExecOptions, ExecResult (..), + execStmt) +import GHC.LanguageExtensions.Type (Extension (..)) +import GhcMonad (Ghc, liftIO, modifySession) +import HscTypes +import Ide.Plugin.Eval.Types (Language (Plain), Loc, + Located (..), + Section (sectionLanguage), + Test (..), Txt, locate, + locate0) +import InteractiveEval (getContext, parseImportDecl, + runDecls, setContext) +import Language.LSP.Types.Lens (line, start) +import System.IO.Extra (newTempFile, readFile') + +-- | Return the ranges of the expression and result parts of the given test +testRanges :: Test -> (Range, Range) +testRanges tst = + let startLine = testRange tst ^. start.line + (exprLines, resultLines) = testLenghts tst + resLine = startLine + exprLines + in ( Range + (Position startLine 0) + --(Position (startLine + exprLines + resultLines) 0), + (Position resLine 0) + , Range (Position resLine 0) (Position (resLine + resultLines) 0) + ) + +{- |The document range where a test is defined + testRange :: Loc Test -> Range + testRange = fst . testRanges +-} + +-- |The document range where the result of the test is defined +resultRange :: Test -> Range +resultRange = snd . testRanges + +-- TODO: handle BLANKLINE +{- +>>> showDiffs $ getDiff ["abc","def","ghi","end"] ["abc","def","Z","ZZ","end"] +["abc","def","WAS ghi","NOW Z","NOW ZZ","end"] +-} +showDiffs :: (Semigroup a, IsString a) => [Diff a] -> [a] +showDiffs = map showDiff + +showDiff :: (Semigroup a, IsString a) => Diff a -> a +showDiff (First w) = "WAS " <> w +showDiff (Second w) = "NOW " <> w +showDiff (Both w _) = w + +testCheck :: (Section, Test) -> [T.Text] -> [T.Text] +testCheck (section, test) out + | null (testOutput test) || sectionLanguage section == Plain = out + | otherwise = showDiffs $ getDiff (map T.pack $ testOutput test) out + +testLenghts :: Test -> (Int, Int) +testLenghts (Example e r _) = (NE.length e, length r) +testLenghts (Property _ r _) = (1, length r) + +-- |A one-line Haskell statement +type Statement = Loc String + +asStatements :: Test -> [Statement] +asStatements lt = locate $ Located (testRange lt ^. start.line) (asStmts lt) + +asStmts :: Test -> [Txt] +asStmts (Example e _ _) = NE.toList e +asStmts (Property t _ _) = + ["prop11 = " ++ t, "(propEvaluation prop11 :: IO String)"] + +-- |GHC extensions required for expression evaluation +evalExtensions :: [Extension] +evalExtensions = + [ OverlappingInstances + , UndecidableInstances + , FlexibleInstances + , IncoherentInstances + , TupleSections + ] + +-- |GHC declarations required for expression evaluation +evalSetup :: Ghc () +evalSetup = do + preludeAsP <- parseImportDecl "import qualified Prelude as P" + context <- getContext + setContext (IIDecl preludeAsP : context) + +-- | A wrapper of 'InteractiveEval.execStmt', capturing the execution result +myExecStmt :: String -> ExecOptions -> Ghc (Either String (Maybe String)) +myExecStmt stmt opts = do + (temp, purge) <- liftIO newTempFile + evalPrint <- head <$> runDecls ("evalPrint x = P.writeFile "<> show temp <> " (P.show x)") + modifySession $ \hsc -> hsc {hsc_IC = setInteractivePrintName (hsc_IC hsc) evalPrint} + result <- execStmt stmt opts >>= \case + ExecComplete (Left err) _ -> pure $ Left $ show err + ExecComplete (Right _) _ -> liftIO $ Right . (\x -> if null x then Nothing else Just x) <$> readFile' temp + ExecBreak{} -> pure $ Right $ Just "breakpoints are not supported" + liftIO purge + pure result + +{- |GHC declarations required to execute test properties + +Example: + +prop> \(l::[Bool]) -> reverse (reverse l) == l ++++ OK, passed 100 tests. + +prop> \(l::[Bool]) -> reverse l == l +*** Failed! Falsified (after 6 tests and 2 shrinks): +[True,False] +-} +propSetup :: [Loc [Char]] +propSetup = + locate0 + [ ":set -XScopedTypeVariables -XExplicitForAll" + , "import qualified Test.QuickCheck as Q11" + , "propEvaluation p = Q11.quickCheckWithResult Q11.stdArgs p >>= error . Q11.output" -- uses `error` to get a multi-line display + ] diff --git a/src/Ide/Plugin/Eval/CodeLens.hs b/src/Ide/Plugin/Eval/CodeLens.hs --- a/src/Ide/Plugin/Eval/CodeLens.hs +++ b/src/Ide/Plugin/Eval/CodeLens.hs @@ -1,767 +1,711 @@ -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE ExtendedDefaultRules #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE NoMonomorphismRestriction #-} -{-# OPTIONS_GHC -fno-warn-type-defaults #-} - -{- | -A plugin inspired by the REPLoid feature of , 's Examples and Properties and . - -For a full example see the "Ide.Plugin.Eval.Tutorial" module. --} -module Ide.Plugin.Eval.CodeLens ( - codeLens, - evalCommand, -) where - -import Control.Applicative (Alternative ((<|>))) -import Control.Arrow (second, (>>>)) -import qualified Control.Exception as E -import Control.Monad - ( void, - when, guard, - join - ) -import Control.Monad.IO.Class (MonadIO (liftIO)) -import Control.Monad.Trans.Except - ( ExceptT (..), - ) -import Data.Aeson (toJSON) -import Data.Char (isSpace) -import qualified Data.HashMap.Strict as HashMap -import Data.List - (dropWhileEnd, - find, intercalate - ) -import qualified Data.Map.Strict as Map -import Data.Maybe - ( catMaybes, - fromMaybe, - ) -import Data.String (IsString) -import Data.Text (Text) -import qualified Data.Text as T -import Data.Time (getCurrentTime) -import Data.Typeable (Typeable) -import Development.IDE - ( Action, - realSrcSpanToRange, GetModSummary (..), - GetParsedModuleWithComments (..), - HscEnvEq, - IdeState, - evalGhcEnv, - hscEnvWithImportPaths, - runAction, - textToStringBuffer, - toNormalizedFilePath', - uriToFilePath', - useWithStale_, - prettyPrint, - use_, useNoFile_, uses_, - GhcSessionIO(..), GetDependencies(..), GetModIface(..), - HiFileResult (hirHomeMod, hirModSummary) - ) -import Development.IDE.Core.Rules (TransitiveDependencies(transitiveModuleDeps)) -import Development.IDE.Core.Compile (setupFinderCache, loadModulesHome) -import Development.IDE.GHC.Compat (AnnotationComment(AnnBlockComment, AnnLineComment), GenLocated (L), HscEnv, ParsedModule (..), SrcSpan (RealSrcSpan, UnhelpfulSpan), srcSpanFile, GhcException, setInteractiveDynFlags) -import Development.IDE.Types.Options -import DynamicLoading (initializePlugins) -import FastString (unpackFS) -import GHC - (ExecOptions - ( execLineNumber, - execSourceFile - ), - ExecResult (..), - GeneralFlag (..), - Ghc, - GhcLink (LinkInMemory), - GhcMode (CompManager), - GhcMonad (getSession), - HscTarget (HscInterpreted), - LoadHowMuch (LoadAllTargets), - ModSummary (ms_hspp_opts), - Module (moduleName), - SuccessFlag (Failed, Succeeded), - TcRnExprMode (..), - execOptions, - execStmt, - exprType, - getInteractiveDynFlags, - getSessionDynFlags, - isImport, - isStmt, - load, - runDecls, - setContext, - setLogAction, - setSessionDynFlags, - setTargets, - typeKind, - ) -import GhcPlugins - ( DynFlags (..), - hsc_dflags, - defaultLogActionHPutStrDoc, - gopt_set, - gopt_unset, - interpWays, - targetPlatform, - updateWays, - wayGeneralFlags, - wayUnsetGeneralFlags, - xopt_set, parseDynamicFlagsCmdLine - ) -import HscTypes - ( InteractiveImport (IIModule), - ModSummary (ms_mod), - Target (Target), - TargetId (TargetFile), - ) -import Ide.Plugin.Eval.Code - ( Statement, - asStatements, - evalExpr, - evalExtensions, - evalSetup, - propSetup, - resultRange, - testCheck, - testRanges, - ) -import Ide.Plugin.Eval.GHC - ( addImport, - addPackages, - hasPackage, - isExpr, - showDynFlags, - ) -import Ide.Plugin.Eval.Parse.Comments (commentsToSections) -import Ide.Plugin.Eval.Parse.Option (parseSetFlags) -import Ide.Plugin.Eval.Types -import Ide.Plugin.Eval.Util - ( asS, - gStrictTry, - handleMaybe, - handleMaybeM, - isLiterate, - logWith, - response, - response', - timed, - ) -import Ide.Types -import Language.LSP.Server -import Language.LSP.Types -import Language.LSP.VFS (virtualFileText) -import Outputable - ( nest, - ppr, - showSDoc, - text, - ($$), - (<+>), - ) -import System.FilePath (takeFileName) -import System.IO (hClose) -import UnliftIO.Temporary (withSystemTempFile) -import Util (OverridingBool (Never)) -import Development.IDE.Core.PositionMapping (toCurrentRange) -import qualified Data.DList as DL -import Control.Lens ((^.), _1, (%~), (<&>), _3) -import Language.LSP.Types.Lens (line, end) -import CmdLineParser -import qualified Development.IDE.GHC.Compat as SrcLoc -import Control.Exception (try) - -{- | Code Lens provider - NOTE: Invoked every time the document is modified, not just when the document is saved. --} -codeLens :: PluginMethodHandler IdeState TextDocumentCodeLens -codeLens st plId CodeLensParams{_textDocument} = - let dbg = logWith st - perf = timed dbg - in perf "codeLens" $ - response $ do - let TextDocumentIdentifier uri = _textDocument - fp <- handleMaybe "uri" $ uriToFilePath' uri - let nfp = toNormalizedFilePath' fp - isLHS = isLiterate fp - dbg "fp" fp - (ParsedModule{..}, posMap) <- liftIO $ - runAction "parsed" st $ useWithStale_ GetParsedModuleWithComments nfp - let comments = foldMap - ( foldMap $ \case - L (RealSrcSpan real) bdy - | unpackFS (srcSpanFile real) == - fromNormalizedFilePath nfp - , let ran0 = realSrcSpanToRange real - , Just curRan <- toCurrentRange posMap ran0 - -> - - -- since Haddock parsing is unset explicitly in 'getParsedModuleWithComments', - -- we can concentrate on these two - case bdy of - AnnLineComment cmt -> - mempty { lineComments = Map.singleton curRan (RawLineComment cmt) } - AnnBlockComment cmt -> - mempty { blockComments = Map.singleton curRan $ RawBlockComment cmt } - _ -> mempty - _ -> mempty - ) - $ snd pm_annotations - dbg "excluded comments" $ show $ DL.toList $ - foldMap - (foldMap $ \(L a b) -> - case b of - AnnLineComment{} -> mempty - AnnBlockComment{} -> mempty - _ -> DL.singleton (a, b) - ) - $ snd pm_annotations - dbg "comments" $ show comments - - -- Extract tests from source code - let Sections{..} = commentsToSections isLHS comments - tests = testsBySection nonSetupSections - cmd = mkLspCommand plId evalCommandName "Evaluate=..." (Just []) - let lenses = - [ CodeLens testRange (Just cmd') Nothing - | (section, ident, test) <- tests - , let (testRange, resultRange) = testRanges test - args = EvalParams (setupSections ++ [section]) _textDocument ident - cmd' = - (cmd :: Command) - { _arguments = Just (List [toJSON args]) - , _title = - if trivial resultRange - then "Evaluate..." - else "Refresh..." - } - ] - - perf "tests" $ - dbg "Tests" $ - unwords - [ show (length tests) - , "tests in" - , show (length nonSetupSections) - , "sections" - , show (length setupSections) - , "setups" - , show (length lenses) - , "lenses." - ] - - return $ List lenses - where - trivial (Range p p') = p == p' - -evalCommandName :: CommandId -evalCommandName = "evalCommand" - -evalCommand :: PluginCommand IdeState -evalCommand = PluginCommand evalCommandName "evaluate" runEvalCmd - -type EvalId = Int - -runEvalCmd :: CommandFunction IdeState EvalParams -runEvalCmd st EvalParams{..} = - let dbg = logWith st - perf = timed dbg - cmd :: ExceptT String (LspM c) WorkspaceEdit - cmd = do - let tests = map (\(a,_,b) -> (a,b)) $ testsBySection sections - - let TextDocumentIdentifier{_uri} = module_ - fp <- handleMaybe "uri" $ uriToFilePath' _uri - let nfp = toNormalizedFilePath' fp - mdlText <- moduleText _uri - - session <- runGetSession st nfp - - (ms, _) <- - liftIO $ - runAction "runEvalCmd.getModSummary" st $ - use_ GetModSummary nfp - - now <- liftIO getCurrentTime - - let modName = moduleName $ ms_mod ms - thisModuleTarget = - Target - (TargetFile fp Nothing) - False - (Just (textToStringBuffer mdlText, now)) - - -- Setup environment for evaluation - hscEnv' <- ExceptT $ fmap join $ withSystemTempFile (takeFileName fp) $ \logFilename logHandle -> liftIO . gStrictTry . evalGhcEnv session $ do - env <- getSession - - -- Install the module pragmas and options - df <- liftIO $ setupDynFlagsForGHCiLike env $ ms_hspp_opts ms - - -- Restore the original import paths - let impPaths = importPaths $ hsc_dflags env - df <- return df{importPaths = impPaths} - - -- Set the modified flags in the session - _lp <- setSessionDynFlags df - - -- property tests need QuickCheck - when (needsQuickCheck tests) $ void $ addPackages ["QuickCheck"] - dbg "QUICKCHECK NEEDS" $ needsQuickCheck tests - dbg "QUICKCHECK HAS" $ hasQuickCheck df - - -- copy the package state to the interactive DynFlags - idflags <- getInteractiveDynFlags - df <- getSessionDynFlags - setInteractiveDynFlags $ - (foldl xopt_set idflags evalExtensions) - { pkgState = - pkgState - df - , pkgDatabase = - pkgDatabase - df - , packageFlags = - packageFlags - df - , useColor = Never - , canUseColor = False - } - - -- set up a custom log action - setLogAction $ \_df _wr _sev _span _style _doc -> - defaultLogActionHPutStrDoc _df logHandle _doc _style - - -- Load the module with its current content (as the saved module might not be up to date) - -- BUG: this fails for files that requires preprocessors (e.g. CPP) for ghc < 8.8 - -- see https://gitlab.haskell.org/ghc/ghc/-/issues/17066 - -- and https://hackage.haskell.org/package/ghc-8.10.1/docs/GHC.html#v:TargetFile - eSetTarget <- gStrictTry $ setTargets [thisModuleTarget] - dbg "setTarget" eSetTarget - - -- load the module in the interactive environment - loadResult <- perf "loadModule" $ load LoadAllTargets - dbg "LOAD RESULT" $ asS loadResult - case loadResult of - Failed -> liftIO $ do - hClose logHandle - err <- readFile logFilename - dbg "load ERR" err - return $ Left err - Succeeded -> do - -- Evaluation takes place 'inside' the module - setContext [IIModule modName] - Right <$> getSession - - edits <- - perf "edits" $ - liftIO $ - evalGhcEnv hscEnv' $ - runTests - (st, fp) - tests - - let workspaceEditsMap = HashMap.fromList [(_uri, List $ addFinalReturn mdlText edits)] - let workspaceEdits = WorkspaceEdit (Just workspaceEditsMap) Nothing - - return workspaceEdits - in perf "evalCmd" $ - withIndefiniteProgress "Evaluating" Cancellable $ - response' cmd - -addFinalReturn :: Text -> [TextEdit] -> [TextEdit] -addFinalReturn mdlText edits - | not (null edits) && not (T.null mdlText) && T.last mdlText /= '\n' = - finalReturn mdlText : edits - | otherwise = edits - -finalReturn :: Text -> TextEdit -finalReturn txt = - let ls = T.lines txt - l = length ls -1 - c = T.length . last $ ls - p = Position l c - in TextEdit (Range p p) "\n" - -moduleText :: (IsString e, MonadLsp c m) => Uri -> ExceptT e m Text -moduleText uri = - handleMaybeM "mdlText" $ - (virtualFileText <$>) - <$> getVirtualFile - (toNormalizedUri uri) - -testsBySection :: [Section] -> [(Section, EvalId, Test)] -testsBySection sections = - [(section, ident, test) - | (ident, section) <- zip [0..] sections - , test <- sectionTests section - ] - -type TEnv = (IdeState, String) - -runTests :: TEnv -> [(Section, Test)] -> Ghc [TextEdit] -runTests e@(_st, _) tests = do - df <- getInteractiveDynFlags - evalSetup - when (hasQuickCheck df && needsQuickCheck tests) $ void $ evals e df propSetup - - mapM (processTest e df) tests - where - processTest :: TEnv -> DynFlags -> (Section, Test) -> Ghc TextEdit - processTest e@(st, fp) df (section, test) = do - let dbg = logWith st - let pad = pad_ $ (if isLiterate fp then ("> " `T.append`) else id) $ padPrefix (sectionFormat section) - - rs <- runTest e df test - dbg "TEST RESULTS" rs - - let checkedResult = testCheck (section, test) rs - - let edit = asEdit (sectionFormat section) test (map pad checkedResult) - dbg "TEST EDIT" edit - return edit - - -- runTest :: String -> DynFlags -> Loc Test -> Ghc [Text] - runTest _ df test - | not (hasQuickCheck df) && isProperty test = - return $ - singleLine - "Add QuickCheck to your cabal dependencies to run this test." - runTest e df test = evals e df (asStatements test) - -asEdit :: Format -> Test -> [Text] -> TextEdit -asEdit (MultiLine commRange) test resultLines - -- A test in a block comment, ending with @-\}@ without newline in-between. - | testRange test ^. end.line == commRange ^. end . line - = - TextEdit - (Range - (testRange test ^. end) - (resultRange test ^. end) - ) - ("\n" <> T.unlines (resultLines <> ["-}"])) -asEdit _ test resultLines = - TextEdit (resultRange test) (T.unlines resultLines) - -{- -The result of evaluating a test line can be: -* a value -* nothing -* a (possibly multiline) error message - -A value is returned for a correct expression. - -Either a pure value: ->>> 'h' :"askell" -"haskell" - -Or an 'IO a' (output on stdout/stderr is ignored): ->>> print "OK" >> return "ABC" -"ABC" - -Nothing is returned for a correct directive: - ->>>:set -XFlexibleInstances ->>> import Data.Maybe - -Nothing is returned for a correct declaration (let..,x=, data, class) - ->>> let x = 11 ->>> y = 22 ->>> data B = T | F ->>> class C a - -Nothing is returned for an empty line: - ->>> - -A, possibly multi line, error is returned for a wrong declaration, directive or value or an exception thrown by the evaluated code: - ->>>:set -XNonExistent -Unknown extension: "NonExistent" - ->>> cls C -Variable not in scope: cls :: t0 -> () -Data constructor not in scope: C - ->>> "A -lexical error in string/character literal at end of input - ->>> 3 `div` 0 -divide by zero - ->>> error "Something went wrong\nbad times" :: E.SomeException -Something went wrong -bad times - -Or for a value that does not have a Show instance and can therefore not be displayed: ->>> data V = V ->>> V -No instance for (Show V) --} -evals :: TEnv -> DynFlags -> [Statement] -> Ghc [Text] -evals (st, fp) df stmts = do - er <- gStrictTry $ mapM eval stmts - return $ case er of - Left err -> errorLines err - Right rs -> concat . catMaybes $ rs - where - dbg = logWith st - eval :: Statement -> Ghc (Maybe [Text]) - eval (Located l stmt) - | -- GHCi flags - Just (words -> flags) <- parseSetFlags stmt = do - dbg "{:SET" flags - ndf <- getInteractiveDynFlags - dbg "pre set" $ showDynFlags ndf - eans <- - liftIO $ try @GhcException $ - parseDynamicFlagsCmdLine ndf - (map (L $ UnhelpfulSpan "") flags) - dbg "parsed flags" $ eans - <&> (_1 %~ showDynFlags >>> _3 %~ map warnMsg) - case eans of - Left err -> pure $ Just $ errorLines $ show err - Right (df', ignoreds, warns) -> do - let warnings = do - guard $ not $ null warns - pure $ errorLines $ - unlines $ - map prettyWarn warns - igns = do - guard $ not $ null ignoreds - pure - ["Some flags have not been recognized: " - <> T.pack (intercalate ", " $ map SrcLoc.unLoc ignoreds) - ] - dbg "post set" $ showDynFlags df' - _ <- setSessionDynFlags df' - sessDyns <- getSessionDynFlags - setInteractiveDynFlags sessDyns - pure $ warnings <> igns - | -- A type/kind command - Just (cmd, arg) <- parseGhciLikeCmd $ T.pack stmt = - evalGhciLikeCmd cmd arg - | -- An expression - isExpr df stmt = - do - dbg "{EXPR" stmt - eres <- gStrictTry $ evalExpr stmt - dbg "RES ->" eres - let res = case eres of - Left err -> errorLines err - Right rs -> [T.pack rs] - dbg "EXPR} ->" res - return . Just $ res - | -- A statement - isStmt df stmt = - do - dbg "{STMT " stmt - res <- exec stmt l - r <- case res of - ExecComplete (Left err) _ -> return . Just . errorLines . show $ err - ExecComplete (Right _) _ -> return Nothing - ExecBreak{} -> - return . Just . singleLine $ "breakpoints are not supported" - dbg "STMT} -> " r - return r - | -- An import - isImport df stmt = - do - dbg "{IMPORT " stmt - _ <- addImport stmt - return Nothing - | -- A declaration - otherwise = - do - dbg "{DECL " stmt - void $ runDecls stmt - return Nothing - exec stmt l = - let opts = execOptions{execSourceFile = fp, execLineNumber = l} - in execStmt stmt opts - -prettyWarn :: Warn -> String -prettyWarn Warn{..} = - prettyPrint (SrcLoc.getLoc warnMsg) <> ": warning:\n" - <> " " <> SrcLoc.unLoc warnMsg - -ghcSessionDepsDefinition :: HscEnvEq -> NormalizedFilePath -> Action HscEnv -ghcSessionDepsDefinition env file = do - let hsc = hscEnvWithImportPaths env - deps <- use_ GetDependencies file - let tdeps = transitiveModuleDeps deps - ifaces <- uses_ GetModIface tdeps - - -- Currently GetDependencies returns things in topological order so A comes before B if A imports B. - -- We need to reverse this as GHC gets very unhappy otherwise and complains about broken interfaces. - -- Long-term we might just want to change the order returned by GetDependencies - let inLoadOrder = reverse (map hirHomeMod ifaces) - - liftIO $ loadModulesHome inLoadOrder <$> setupFinderCache (map hirModSummary ifaces) hsc - -runGetSession :: MonadIO m => IdeState -> NormalizedFilePath -> m HscEnv -runGetSession st nfp = liftIO $ runAction "eval" st $ do - -- Create a new GHC Session rather than reusing an existing one - -- to avoid interfering with ghcide - IdeGhcSession{loadSessionFun} <- useNoFile_ GhcSessionIO - let fp = fromNormalizedFilePath nfp - ((_, res),_) <- liftIO $ loadSessionFun fp - let hscEnv = fromMaybe (error $ "Unknown file: " <> fp) res - ghcSessionDepsDefinition hscEnv nfp - -needsQuickCheck :: [(Section, Test)] -> Bool -needsQuickCheck = any (isProperty . snd) - -hasQuickCheck :: DynFlags -> Bool -hasQuickCheck df = hasPackage df "QuickCheck" - -singleLine :: String -> [Text] -singleLine s = [T.pack s] - -{- | - Convert error messages to a list of text lines - Remove unnecessary information. --} -errorLines :: String -> [Text] -errorLines = - map (\e -> fromMaybe e (T.stripSuffix "arising from a use of ‘asPrint’" e)) - . dropWhileEnd T.null - . takeWhile (not . ("CallStack" `T.isPrefixOf`)) - . T.lines - . T.pack - -{- | ->>> map (pad_ (T.pack "--")) (map T.pack ["2+2",""]) -["--2+2","--"] --} -pad_ :: Text -> Text -> Text -pad_ prefix = (prefix `T.append`) . convertBlank - -convertBlank :: Text -> Text -convertBlank x - | T.null x = "" - | otherwise = x - -padPrefix :: IsString p => Format -> p -padPrefix SingleLine = "-- " -padPrefix _ = "" - -{- | Resulting @Text@ MUST NOT prefix each line with @--@ - Such comment-related post-process will be taken place - solely in 'evalGhciLikeCmd'. --} -type GHCiLikeCmd = DynFlags -> Text -> Ghc (Maybe Text) - --- Should we use some sort of trie here? -ghciLikeCommands :: [(Text, GHCiLikeCmd)] -ghciLikeCommands = - [("kind", doKindCmd False), ("kind!", doKindCmd True), ("type", doTypeCmd)] - -evalGhciLikeCmd :: Text -> Text -> Ghc (Maybe [Text]) -evalGhciLikeCmd cmd arg = do - df <- getSessionDynFlags - case lookup cmd ghciLikeCommands - <|> snd - <$> find (T.isPrefixOf cmd . fst) ghciLikeCommands of - Just hndler -> - fmap - T.lines - <$> hndler df arg - _ -> E.throw $ GhciLikeCmdNotImplemented cmd arg - -doKindCmd :: Bool -> DynFlags -> Text -> Ghc (Maybe Text) -doKindCmd False df arg = do - let input = T.strip arg - (_, kind) <- typeKind False $ T.unpack input - let kindText = text (T.unpack input) <+> "::" <+> ppr kind - pure $ Just $ T.pack (showSDoc df kindText) -doKindCmd True df arg = do - let input = T.strip arg - (ty, kind) <- typeKind True $ T.unpack input - let kindDoc = text (T.unpack input) <+> "::" <+> ppr kind - tyDoc = "=" <+> ppr ty - pure $ Just $ T.pack (showSDoc df $ kindDoc $$ tyDoc) - -doTypeCmd :: DynFlags -> Text -> Ghc (Maybe Text) -doTypeCmd dflags arg = do - let (emod, expr) = parseExprMode arg - ty <- exprType emod $ T.unpack expr - let rawType = T.strip $ T.pack $ showSDoc dflags $ ppr ty - broken = T.any (\c -> c == '\r' || c == '\n') rawType - pure $ - Just $ - if broken - then - T.pack $ - showSDoc dflags $ - text (T.unpack expr) - $$ nest 2 ("::" <+> ppr ty) - else expr <> " :: " <> rawType <> "\n" - -parseExprMode :: Text -> (TcRnExprMode, T.Text) -parseExprMode rawArg = case T.break isSpace rawArg of - ("+v", rest) -> (TM_NoInst, T.strip rest) - ("+d", rest) -> (TM_Default, T.strip rest) - _ -> (TM_Inst, rawArg) - -data GhciLikeCmdException = GhciLikeCmdNotImplemented - { ghciCmdName :: Text - , ghciCmdArg :: Text - } - deriving (Typeable) - -instance Show GhciLikeCmdException where - showsPrec _ GhciLikeCmdNotImplemented{..} = - showString "unknown command '" - . showString (T.unpack ghciCmdName) - . showChar '\'' - -instance E.Exception GhciLikeCmdException - -{- ->>> parseGhciLikeCmd (T.pack ":kind! N + M + 1") -Just ("kind!","N + M + 1") ->>> parseGhciLikeCmd (T.pack ":kind a") -Just ("kind","a") --} -parseGhciLikeCmd :: Text -> Maybe (Text, Text) -parseGhciLikeCmd input = do - (':', rest) <- T.uncons $ T.stripStart input - pure $ second T.strip $ T.break isSpace rest - -setupDynFlagsForGHCiLike :: HscEnv -> DynFlags -> IO DynFlags -setupDynFlagsForGHCiLike env dflags = do - let dflags3 = - dflags - { hscTarget = HscInterpreted - , ghcMode = CompManager - , ghcLink = LinkInMemory - } - platform = targetPlatform dflags3 - dflags3a = updateWays $ dflags3{ways = interpWays} - dflags3b = - foldl gopt_set dflags3a $ - concatMap (wayGeneralFlags platform) interpWays - dflags3c = - foldl gopt_unset dflags3b $ - concatMap (wayUnsetGeneralFlags platform) interpWays - dflags4 = - dflags3c - `gopt_set` Opt_ImplicitImportQualified - `gopt_set` Opt_IgnoreOptimChanges - `gopt_set` Opt_IgnoreHpcChanges - `gopt_unset` Opt_DiagnosticsShowCaret - initializePlugins env dflags4 +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE ExtendedDefaultRules #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -fno-warn-type-defaults #-} + +{- | +A plugin inspired by the REPLoid feature of , 's Examples and Properties and . + +For a full example see the "Ide.Plugin.Eval.Tutorial" module. +-} +module Ide.Plugin.Eval.CodeLens ( + codeLens, + evalCommand, +) where + +import CmdLineParser +import Control.Applicative (Alternative ((<|>))) +import Control.Arrow (second, (>>>)) +import Control.Exception (try) +import qualified Control.Exception as E +import Control.Lens (_1, _3, (%~), (<&>), + (^.)) +import Control.Monad (guard, join, void, when) +import Control.Monad.IO.Class (MonadIO (liftIO)) +import Control.Monad.Trans.Except (ExceptT (..)) +import Data.Aeson (toJSON) +import Data.Char (isSpace) +import qualified Data.DList as DL +import qualified Data.HashMap.Strict as HashMap +import Data.List (dropWhileEnd, find, + intercalate) +import qualified Data.Map.Strict as Map +import Data.Maybe (catMaybes, fromMaybe) +import Data.String (IsString) +import Data.Text (Text) +import qualified Data.Text as T +import Data.Time (getCurrentTime) +import Data.Typeable (Typeable) +import Development.IDE (Action, + GetDependencies (..), + GetModIface (..), + GetModSummary (..), + GetParsedModuleWithComments (..), + GhcSessionIO (..), + HiFileResult (hirHomeMod, hirModSummary), + HscEnvEq, IdeState, + ModSummaryResult (..), + evalGhcEnv, + hscEnvWithImportPaths, + prettyPrint, + realSrcSpanToRange, + runAction, + textToStringBuffer, + toNormalizedFilePath', + uriToFilePath', + useNoFile_, + useWithStale_, use_, + uses_) +import Development.IDE.Core.Compile (loadModulesHome, + setupFinderCache) +import Development.IDE.Core.PositionMapping (toCurrentRange) +import Development.IDE.Core.Rules (TransitiveDependencies (transitiveModuleDeps)) +import Development.IDE.GHC.Compat (AnnotationComment (AnnBlockComment, AnnLineComment), + GenLocated (L), + GhcException, HscEnv, + ParsedModule (..), + SrcSpan (RealSrcSpan, UnhelpfulSpan), + setInteractiveDynFlags, + srcSpanFile) +import qualified Development.IDE.GHC.Compat as SrcLoc +import Development.IDE.Types.Options +import DynamicLoading (initializePlugins) +import FastString (unpackFS) +import GHC (ExecOptions (execLineNumber, execSourceFile), + GeneralFlag (..), Ghc, + GhcLink (LinkInMemory), + GhcMode (CompManager), + GhcMonad (getSession), + HscTarget (HscInterpreted), + LoadHowMuch (LoadAllTargets), + ModSummary (ms_hspp_opts), + Module (moduleName), + SuccessFlag (Failed, Succeeded), + TcRnExprMode (..), + execOptions, exprType, + getInteractiveDynFlags, + getSessionDynFlags, + isImport, isStmt, load, + runDecls, setContext, + setLogAction, + setSessionDynFlags, + setTargets, typeKind) +import GhcPlugins (DynFlags (..), + defaultLogActionHPutStrDoc, + gopt_set, gopt_unset, + hsc_dflags, interpWays, + parseDynamicFlagsCmdLine, + targetPlatform, + updateWays, + wayGeneralFlags, + wayUnsetGeneralFlags, + xopt_set) +import HscTypes (InteractiveImport (IIModule), + ModSummary (ms_mod), + Target (Target), + TargetId (TargetFile)) +import Ide.Plugin.Eval.Code (Statement, asStatements, + evalExtensions, + evalSetup, myExecStmt, + propSetup, resultRange, + testCheck, testRanges) +import Ide.Plugin.Eval.GHC (addImport, addPackages, + hasPackage, showDynFlags) +import Ide.Plugin.Eval.Parse.Comments (commentsToSections) +import Ide.Plugin.Eval.Parse.Option (parseSetFlags) +import Ide.Plugin.Eval.Types +import Ide.Plugin.Eval.Util (asS, gStrictTry, + handleMaybe, + handleMaybeM, isLiterate, + logWith, response, + response', timed) +import Ide.Types +import Language.LSP.Server +import Language.LSP.Types +import Language.LSP.Types.Lens (end, line) +import Language.LSP.VFS (virtualFileText) +import Outputable (nest, ppr, showSDoc, + text, ($$), (<+>)) +import System.FilePath (takeFileName) +import System.IO (hClose) +import UnliftIO.Temporary (withSystemTempFile) +import Util (OverridingBool (Never)) + +{- | Code Lens provider + NOTE: Invoked every time the document is modified, not just when the document is saved. +-} +codeLens :: PluginMethodHandler IdeState TextDocumentCodeLens +codeLens st plId CodeLensParams{_textDocument} = + let dbg = logWith st + perf = timed dbg + in perf "codeLens" $ + response $ do + let TextDocumentIdentifier uri = _textDocument + fp <- handleMaybe "uri" $ uriToFilePath' uri + let nfp = toNormalizedFilePath' fp + isLHS = isLiterate fp + dbg "fp" fp + (ParsedModule{..}, posMap) <- liftIO $ + runAction "parsed" st $ useWithStale_ GetParsedModuleWithComments nfp + let comments = foldMap + ( foldMap $ \case + L (RealSrcSpan real) bdy + | unpackFS (srcSpanFile real) == + fromNormalizedFilePath nfp + , let ran0 = realSrcSpanToRange real + , Just curRan <- toCurrentRange posMap ran0 + -> + + -- since Haddock parsing is unset explicitly in 'getParsedModuleWithComments', + -- we can concentrate on these two + case bdy of + AnnLineComment cmt -> + mempty { lineComments = Map.singleton curRan (RawLineComment cmt) } + AnnBlockComment cmt -> + mempty { blockComments = Map.singleton curRan $ RawBlockComment cmt } + _ -> mempty + _ -> mempty + ) + $ snd pm_annotations + dbg "excluded comments" $ show $ DL.toList $ + foldMap + (foldMap $ \(L a b) -> + case b of + AnnLineComment{} -> mempty + AnnBlockComment{} -> mempty + _ -> DL.singleton (a, b) + ) + $ snd pm_annotations + dbg "comments" $ show comments + + -- Extract tests from source code + let Sections{..} = commentsToSections isLHS comments + tests = testsBySection nonSetupSections + cmd = mkLspCommand plId evalCommandName "Evaluate=..." (Just []) + let lenses = + [ CodeLens testRange (Just cmd') Nothing + | (section, ident, test) <- tests + , let (testRange, resultRange) = testRanges test + args = EvalParams (setupSections ++ [section]) _textDocument ident + cmd' = + (cmd :: Command) + { _arguments = Just (List [toJSON args]) + , _title = + if trivial resultRange + then "Evaluate..." + else "Refresh..." + } + ] + + perf "tests" $ + dbg "Tests" $ + unwords + [ show (length tests) + , "tests in" + , show (length nonSetupSections) + , "sections" + , show (length setupSections) + , "setups" + , show (length lenses) + , "lenses." + ] + + return $ List lenses + where + trivial (Range p p') = p == p' + +evalCommandName :: CommandId +evalCommandName = "evalCommand" + +evalCommand :: PluginCommand IdeState +evalCommand = PluginCommand evalCommandName "evaluate" runEvalCmd + +type EvalId = Int + +runEvalCmd :: CommandFunction IdeState EvalParams +runEvalCmd st EvalParams{..} = + let dbg = logWith st + perf = timed dbg + cmd :: ExceptT String (LspM c) WorkspaceEdit + cmd = do + let tests = map (\(a,_,b) -> (a,b)) $ testsBySection sections + + let TextDocumentIdentifier{_uri} = module_ + fp <- handleMaybe "uri" $ uriToFilePath' _uri + let nfp = toNormalizedFilePath' fp + mdlText <- moduleText _uri + + session <- runGetSession st nfp + + ms <- fmap msrModSummary $ + liftIO $ + runAction "runEvalCmd.getModSummary" st $ + use_ GetModSummary nfp + + now <- liftIO getCurrentTime + + let modName = moduleName $ ms_mod ms + thisModuleTarget = + Target + (TargetFile fp Nothing) + False + (Just (textToStringBuffer mdlText, now)) + + -- Setup environment for evaluation + hscEnv' <- ExceptT $ fmap join $ withSystemTempFile (takeFileName fp) $ \logFilename logHandle -> liftIO . gStrictTry . evalGhcEnv session $ do + env <- getSession + + -- Install the module pragmas and options + df <- liftIO $ setupDynFlagsForGHCiLike env $ ms_hspp_opts ms + + -- Restore the original import paths + let impPaths = importPaths $ hsc_dflags env + df <- return df{importPaths = impPaths} + + -- Set the modified flags in the session + _lp <- setSessionDynFlags df + + -- property tests need QuickCheck + when (needsQuickCheck tests) $ void $ addPackages ["QuickCheck"] + dbg "QUICKCHECK NEEDS" $ needsQuickCheck tests + dbg "QUICKCHECK HAS" $ hasQuickCheck df + + -- copy the package state to the interactive DynFlags + idflags <- getInteractiveDynFlags + df <- getSessionDynFlags + setInteractiveDynFlags $ + (foldl xopt_set idflags evalExtensions) + { pkgState = + pkgState + df + , pkgDatabase = + pkgDatabase + df + , packageFlags = + packageFlags + df + , useColor = Never + , canUseColor = False + } + + -- set up a custom log action + setLogAction $ \_df _wr _sev _span _style _doc -> + defaultLogActionHPutStrDoc _df logHandle _doc _style + + -- Load the module with its current content (as the saved module might not be up to date) + -- BUG: this fails for files that requires preprocessors (e.g. CPP) for ghc < 8.8 + -- see https://gitlab.haskell.org/ghc/ghc/-/issues/17066 + -- and https://hackage.haskell.org/package/ghc-8.10.1/docs/GHC.html#v:TargetFile + eSetTarget <- gStrictTry $ setTargets [thisModuleTarget] + dbg "setTarget" eSetTarget + + -- load the module in the interactive environment + loadResult <- perf "loadModule" $ load LoadAllTargets + dbg "LOAD RESULT" $ asS loadResult + case loadResult of + Failed -> liftIO $ do + hClose logHandle + err <- readFile logFilename + dbg "load ERR" err + return $ Left err + Succeeded -> do + -- Evaluation takes place 'inside' the module + setContext [IIModule modName] + Right <$> getSession + + edits <- + perf "edits" $ + liftIO $ + evalGhcEnv hscEnv' $ + runTests + (st, fp) + tests + + let workspaceEditsMap = HashMap.fromList [(_uri, List $ addFinalReturn mdlText edits)] + let workspaceEdits = WorkspaceEdit (Just workspaceEditsMap) Nothing Nothing + + return workspaceEdits + in perf "evalCmd" $ + withIndefiniteProgress "Evaluating" Cancellable $ + response' cmd + +addFinalReturn :: Text -> [TextEdit] -> [TextEdit] +addFinalReturn mdlText edits + | not (null edits) && not (T.null mdlText) && T.last mdlText /= '\n' = + finalReturn mdlText : edits + | otherwise = edits + +finalReturn :: Text -> TextEdit +finalReturn txt = + let ls = T.lines txt + l = length ls -1 + c = T.length . last $ ls + p = Position l c + in TextEdit (Range p p) "\n" + +moduleText :: (IsString e, MonadLsp c m) => Uri -> ExceptT e m Text +moduleText uri = + handleMaybeM "mdlText" $ + (virtualFileText <$>) + <$> getVirtualFile + (toNormalizedUri uri) + +testsBySection :: [Section] -> [(Section, EvalId, Test)] +testsBySection sections = + [(section, ident, test) + | (ident, section) <- zip [0..] sections + , test <- sectionTests section + ] + +type TEnv = (IdeState, String) + +runTests :: TEnv -> [(Section, Test)] -> Ghc [TextEdit] +runTests e@(_st, _) tests = do + df <- getInteractiveDynFlags + evalSetup + when (hasQuickCheck df && needsQuickCheck tests) $ void $ evals e df propSetup + + mapM (processTest e df) tests + where + processTest :: TEnv -> DynFlags -> (Section, Test) -> Ghc TextEdit + processTest e@(st, fp) df (section, test) = do + let dbg = logWith st + let pad = pad_ $ (if isLiterate fp then ("> " `T.append`) else id) $ padPrefix (sectionFormat section) + + rs <- runTest e df test + dbg "TEST RESULTS" rs + + let checkedResult = testCheck (section, test) rs + + let edit = asEdit (sectionFormat section) test (map pad checkedResult) + dbg "TEST EDIT" edit + return edit + + -- runTest :: String -> DynFlags -> Loc Test -> Ghc [Text] + runTest _ df test + | not (hasQuickCheck df) && isProperty test = + return $ + singleLine + "Add QuickCheck to your cabal dependencies to run this test." + runTest e df test = evals e df (asStatements test) + +asEdit :: Format -> Test -> [Text] -> TextEdit +asEdit (MultiLine commRange) test resultLines + -- A test in a block comment, ending with @-\}@ without newline in-between. + | testRange test ^. end.line == commRange ^. end . line + = + TextEdit + (Range + (testRange test ^. end) + (resultRange test ^. end) + ) + ("\n" <> T.unlines (resultLines <> ["-}"])) +asEdit _ test resultLines = + TextEdit (resultRange test) (T.unlines resultLines) + +{- +The result of evaluating a test line can be: +* a value +* nothing +* a (possibly multiline) error message + +A value is returned for a correct expression. + +Either a pure value: +>>> 'h' :"askell" +"haskell" + +Or an 'IO a' (output on stdout/stderr is ignored): +>>> print "OK" >> return "ABC" +"ABC" + +Nothing is returned for a correct directive: + +>>>:set -XFlexibleInstances +>>> import Data.Maybe + +Nothing is returned for a correct declaration (let..,x=, data, class) + +>>> let x = 11 +>>> y = 22 +>>> data B = T | F +>>> class C a + +Nothing is returned for an empty line: + +>>> + +A, possibly multi line, error is returned for a wrong declaration, directive or value or an exception thrown by the evaluated code: + +>>>:set -XNonExistent +Unknown extension: "NonExistent" + +>>> cls C +Variable not in scope: cls :: t0 -> () +Data constructor not in scope: C + +>>> "A +lexical error in string/character literal at end of input + +>>> 3 `div` 0 +divide by zero + +>>> error "Something went wrong\nbad times" :: E.SomeException +Something went wrong +bad times + +Or for a value that does not have a Show instance and can therefore not be displayed: +>>> data V = V +>>> V +No instance for (Show V) +-} +evals :: TEnv -> DynFlags -> [Statement] -> Ghc [Text] +evals (st, fp) df stmts = do + er <- gStrictTry $ mapM eval stmts + return $ case er of + Left err -> errorLines err + Right rs -> concat . catMaybes $ rs + where + dbg = logWith st + eval :: Statement -> Ghc (Maybe [Text]) + eval (Located l stmt) + | -- GHCi flags + Just (words -> flags) <- parseSetFlags stmt = do + dbg "{:SET" flags + ndf <- getInteractiveDynFlags + dbg "pre set" $ showDynFlags ndf + eans <- + liftIO $ try @GhcException $ + parseDynamicFlagsCmdLine ndf + (map (L $ UnhelpfulSpan "") flags) + dbg "parsed flags" $ eans + <&> (_1 %~ showDynFlags >>> _3 %~ map warnMsg) + case eans of + Left err -> pure $ Just $ errorLines $ show err + Right (df', ignoreds, warns) -> do + let warnings = do + guard $ not $ null warns + pure $ errorLines $ + unlines $ + map prettyWarn warns + igns = do + guard $ not $ null ignoreds + pure + ["Some flags have not been recognized: " + <> T.pack (intercalate ", " $ map SrcLoc.unLoc ignoreds) + ] + dbg "post set" $ showDynFlags df' + _ <- setSessionDynFlags df' + sessDyns <- getSessionDynFlags + setInteractiveDynFlags sessDyns + pure $ warnings <> igns + | -- A type/kind command + Just (cmd, arg) <- parseGhciLikeCmd $ T.pack stmt = + evalGhciLikeCmd cmd arg + | -- A statement + isStmt df stmt = + do + dbg "{STMT " stmt + res <- exec stmt l + r <- case res of + Left err -> return . Just . errorLines $ err + Right x -> return $ singleLine <$> x + dbg "STMT} -> " r + return r + | -- An import + isImport df stmt = + do + dbg "{IMPORT " stmt + _ <- addImport stmt + return Nothing + | -- A declaration + otherwise = + do + dbg "{DECL " stmt + void $ runDecls stmt + return Nothing + exec stmt l = + let opts = execOptions{execSourceFile = fp, execLineNumber = l} + in myExecStmt stmt opts + +prettyWarn :: Warn -> String +prettyWarn Warn{..} = + prettyPrint (SrcLoc.getLoc warnMsg) <> ": warning:\n" + <> " " <> SrcLoc.unLoc warnMsg + +ghcSessionDepsDefinition :: HscEnvEq -> NormalizedFilePath -> Action HscEnv +ghcSessionDepsDefinition env file = do + let hsc = hscEnvWithImportPaths env + deps <- use_ GetDependencies file + let tdeps = transitiveModuleDeps deps + ifaces <- uses_ GetModIface tdeps + + -- Currently GetDependencies returns things in topological order so A comes before B if A imports B. + -- We need to reverse this as GHC gets very unhappy otherwise and complains about broken interfaces. + -- Long-term we might just want to change the order returned by GetDependencies + let inLoadOrder = reverse (map hirHomeMod ifaces) + + liftIO $ loadModulesHome inLoadOrder <$> setupFinderCache (map hirModSummary ifaces) hsc + +runGetSession :: MonadIO m => IdeState -> NormalizedFilePath -> m HscEnv +runGetSession st nfp = liftIO $ runAction "eval" st $ do + -- Create a new GHC Session rather than reusing an existing one + -- to avoid interfering with ghcide + IdeGhcSession{loadSessionFun} <- useNoFile_ GhcSessionIO + let fp = fromNormalizedFilePath nfp + ((_, res),_) <- liftIO $ loadSessionFun fp + let hscEnv = fromMaybe (error $ "Unknown file: " <> fp) res + ghcSessionDepsDefinition hscEnv nfp + +needsQuickCheck :: [(Section, Test)] -> Bool +needsQuickCheck = any (isProperty . snd) + +hasQuickCheck :: DynFlags -> Bool +hasQuickCheck df = hasPackage df "QuickCheck" + +singleLine :: String -> [Text] +singleLine s = [T.pack s] + +{- | + Convert error messages to a list of text lines + Remove unnecessary information. +-} +errorLines :: String -> [Text] +errorLines = + dropWhileEnd T.null + . takeWhile (not . ("CallStack" `T.isPrefixOf`)) + . T.lines + . T.pack + +{- | +>>> map (pad_ (T.pack "--")) (map T.pack ["2+2",""]) +["--2+2","--"] +-} +pad_ :: Text -> Text -> Text +pad_ prefix = (prefix `T.append`) . convertBlank + +convertBlank :: Text -> Text +convertBlank x + | T.null x = "" + | otherwise = x + +padPrefix :: IsString p => Format -> p +padPrefix SingleLine = "-- " +padPrefix _ = "" + +{- | Resulting @Text@ MUST NOT prefix each line with @--@ + Such comment-related post-process will be taken place + solely in 'evalGhciLikeCmd'. +-} +type GHCiLikeCmd = DynFlags -> Text -> Ghc (Maybe Text) + +-- Should we use some sort of trie here? +ghciLikeCommands :: [(Text, GHCiLikeCmd)] +ghciLikeCommands = + [("kind", doKindCmd False), ("kind!", doKindCmd True), ("type", doTypeCmd)] + +evalGhciLikeCmd :: Text -> Text -> Ghc (Maybe [Text]) +evalGhciLikeCmd cmd arg = do + df <- getSessionDynFlags + case lookup cmd ghciLikeCommands + <|> snd + <$> find (T.isPrefixOf cmd . fst) ghciLikeCommands of + Just hndler -> + fmap + T.lines + <$> hndler df arg + _ -> E.throw $ GhciLikeCmdNotImplemented cmd arg + +doKindCmd :: Bool -> DynFlags -> Text -> Ghc (Maybe Text) +doKindCmd False df arg = do + let input = T.strip arg + (_, kind) <- typeKind False $ T.unpack input + let kindText = text (T.unpack input) <+> "::" <+> ppr kind + pure $ Just $ T.pack (showSDoc df kindText) +doKindCmd True df arg = do + let input = T.strip arg + (ty, kind) <- typeKind True $ T.unpack input + let kindDoc = text (T.unpack input) <+> "::" <+> ppr kind + tyDoc = "=" <+> ppr ty + pure $ Just $ T.pack (showSDoc df $ kindDoc $$ tyDoc) + +doTypeCmd :: DynFlags -> Text -> Ghc (Maybe Text) +doTypeCmd dflags arg = do + let (emod, expr) = parseExprMode arg + ty <- exprType emod $ T.unpack expr + let rawType = T.strip $ T.pack $ showSDoc dflags $ ppr ty + broken = T.any (\c -> c == '\r' || c == '\n') rawType + pure $ + Just $ + if broken + then + T.pack $ + showSDoc dflags $ + text (T.unpack expr) + $$ nest 2 ("::" <+> ppr ty) + else expr <> " :: " <> rawType <> "\n" + +parseExprMode :: Text -> (TcRnExprMode, T.Text) +parseExprMode rawArg = case T.break isSpace rawArg of + ("+v", rest) -> (TM_NoInst, T.strip rest) + ("+d", rest) -> (TM_Default, T.strip rest) + _ -> (TM_Inst, rawArg) + +data GhciLikeCmdException = GhciLikeCmdNotImplemented + { ghciCmdName :: Text + , ghciCmdArg :: Text + } + deriving (Typeable) + +instance Show GhciLikeCmdException where + showsPrec _ GhciLikeCmdNotImplemented{..} = + showString "unknown command '" + . showString (T.unpack ghciCmdName) + . showChar '\'' + +instance E.Exception GhciLikeCmdException + +{- +>>> parseGhciLikeCmd (T.pack ":kind! N + M + 1") +Just ("kind!","N + M + 1") +>>> parseGhciLikeCmd (T.pack ":kind a") +Just ("kind","a") +-} +parseGhciLikeCmd :: Text -> Maybe (Text, Text) +parseGhciLikeCmd input = do + (':', rest) <- T.uncons $ T.stripStart input + pure $ second T.strip $ T.break isSpace rest + +setupDynFlagsForGHCiLike :: HscEnv -> DynFlags -> IO DynFlags +setupDynFlagsForGHCiLike env dflags = do + let dflags3 = + dflags + { hscTarget = HscInterpreted + , ghcMode = CompManager + , ghcLink = LinkInMemory + } + platform = targetPlatform dflags3 + dflags3a = updateWays $ dflags3{ways = interpWays} + dflags3b = + foldl gopt_set dflags3a $ + concatMap (wayGeneralFlags platform) interpWays + dflags3c = + foldl gopt_unset dflags3b $ + concatMap (wayUnsetGeneralFlags platform) interpWays + dflags4 = + dflags3c + `gopt_set` Opt_ImplicitImportQualified + `gopt_set` Opt_IgnoreOptimChanges + `gopt_set` Opt_IgnoreHpcChanges + `gopt_unset` Opt_DiagnosticsShowCaret + initializePlugins env dflags4 diff --git a/src/Ide/Plugin/Eval/GHC.hs b/src/Ide/Plugin/Eval/GHC.hs --- a/src/Ide/Plugin/Eval/GHC.hs +++ b/src/Ide/Plugin/Eval/GHC.hs @@ -1,206 +1,174 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# OPTIONS_GHC -fno-warn-unused-imports -Wno-orphans #-} - --- |GHC API utilities -module Ide.Plugin.Eval.GHC ( - isExpr, - addExtension, - addImport, - hasPackage, - addPackages, - modifyFlags, - showDynFlags, -) where - -import Data.List (isPrefixOf) -import Data.Maybe (mapMaybe) -import Development.IDE.GHC.Compat -import qualified EnumSet -import GHC.LanguageExtensions.Type (Extension (..)) -import GhcMonad (modifySession) -import GhcPlugins (DefUnitId (..), InstalledUnitId (..), fsLit, hsc_IC, pprHsString) -import HscTypes (InteractiveContext (ic_dflags)) -import Ide.Plugin.Eval.Util (asS, gStrictTry) -import qualified Lexer -import Module (UnitId (DefiniteUnitId)) -import Outputable ( - Outputable (ppr), - SDoc, - showSDocUnsafe, - text, - vcat, - (<+>), - ) -import qualified Parser -import SrcLoc (mkRealSrcLoc) -import StringBuffer (stringToStringBuffer) -import Data.String (fromString) - -{- $setup ->>> import GHC ->>> import GHC.Paths ->>> run act = runGhc (Just libdir) (getInteractiveDynFlags >>= act) ->>> libdir -"/Users/titto/.ghcup/ghc/8.8.4/lib/ghc-8.8.4" --} - -{- | Returns true if string is an expression - ->>> isExprTst e df = return (isExpr df e) ->>> run $ isExprTst "3" -True - ->>> run $ isExprTst "(x+y)" -True - ->>> run $ isExprTst "import Data.Maybe" -False - ->>> run $ isExprTst "three=3" -False --} -isExpr :: DynFlags -> String -> Bool -isExpr df stmt = case parseThing Parser.parseExpression df stmt of - Lexer.POk _ _ -> True - Lexer.PFailed{} -> False - -parseThing :: Lexer.P thing -> DynFlags -> String -> Lexer.ParseResult thing -parseThing parser dflags stmt = do - let buf = stringToStringBuffer stmt - loc = mkRealSrcLoc (fsLit "") 1 1 - - Lexer.unP parser (Lexer.mkPState dflags buf loc) - -{- | True if specified package is present in DynFlags - --- >>> hasPackageTst pkg = run $ \df -> return (hasPackage df pkg) ->>> hasPackageTst pkg = run $ \_ -> addPackages [pkg] >>= return . either Left (\df -> Right (hasPackage df pkg)) - ->>> hasPackageTst "base" -Right True - ->>> hasPackageTst "ghc" -Right True - ->>> hasPackageTst "extra" -Left ": cannot satisfy -package extra\n (use -v for more information)" - ->>> hasPackageTst "QuickCheck" -Left ": cannot satisfy -package QuickCheck\n (use -v for more information)" --} -hasPackage :: DynFlags -> String -> Bool -hasPackage df = hasPackage_ (packageFlags df) - -hasPackage_ :: [PackageFlag] -> [Char] -> Bool -hasPackage_ pkgFlags name = any (name `isPrefixOf`) (pkgNames_ pkgFlags) - -{- | ->>> run (return . pkgNames) -[] --} -pkgNames :: DynFlags -> [String] -pkgNames = pkgNames_ . packageFlags - -pkgNames_ :: [PackageFlag] -> [String] -pkgNames_ = - mapMaybe - ( \case - ExposePackage _ (PackageArg n) _ -> Just n - ExposePackage _ (UnitIdArg (DefiniteUnitId n)) _ -> Just $ asS n - _ -> Nothing - ) - -{- | Expose a list of packages. ->>> addPackagesTest pkgs = run (\_ -> (packageFlags <$>) <$> addPackages pkgs) - ->>> addPackagesTest [] -Right [] - ->>> addPackagesTest ["base","base","array"] -Right [-package base{package base True ([])},-package array{package array True ([])}] - ->>> addPackagesTest ["Cabal"] -Right [-package Cabal{package Cabal True ([])}] - ->>> addPackagesTest ["QuickCheck"] -Left ": cannot satisfy -package QuickCheck\n (use -v for more information)" - ->>> addPackagesTest ["base","notThere"] -Left ": cannot satisfy -package notThere\n (use -v for more information)" - -prop> \(x::Int) -> x + x == 2 * x -+++ OK, passed 100 tests. --} -addPackages :: [String] -> Ghc (Either String DynFlags) -addPackages pkgNames = gStrictTry $ - modifyFlags $ \df -> - df{packageFlags = foldr (\pkgName pf -> if hasPackage_ pf pkgName then pf else expose pkgName : pf) (packageFlags df) pkgNames} - where - expose name = ExposePackage ("-package " ++ name) (PackageArg name) (ModRenaming True []) - -modifyFlags :: GhcMonad m => (DynFlags -> DynFlags) -> m DynFlags -modifyFlags f = do - df <- getSessionDynFlags - _ <- setSessionDynFlags (f df) - getSessionDynFlags - --- modifyFlags f = do --- modifyDynFlags f --- getSessionDynFlags - -{- | Add import to evaluation context - ->>> run $ \_ -> addImport "import Data.Maybe" -Could not find module ‘Data.Maybe’ -Use -v (or `:set -v` in ghci) to see a list of the files searched for. - ->>> run $ \df -> addPackages ["base"] >> addImport "import Data.Maybe" -[import Data.Maybe] - ->>> run $ \df -> addPackages ["base"] >> addImport "import qualified Data.Maybe as M" -[import qualified Data.Maybe as M] --} -addImport :: GhcMonad m => String -> m [InteractiveImport] -addImport i = do - ctx <- getContext - -- dbgO "CONTEXT" ctx - idecl <- parseImportDecl i - setContext $ IIDecl idecl : ctx - -- ctx' <- getContext - -- dbg "CONTEXT'" ctx' - getContext - -{- | Add extension to interactive evaluation session ->>> import GHC.LanguageExtensions.Type(Extension(..)) ->>> run $ \_ -> addExtension DeriveGeneric -() --} -addExtension :: GhcMonad m => Extension -> m () -addExtension ext = - modifySession $ \hsc -> hsc{hsc_IC = setExtension (hsc_IC hsc) ext} - -setExtension :: InteractiveContext -> Extension -> InteractiveContext -setExtension ic ext = ic{ic_dflags = xopt_set (ic_dflags ic) ext} - -deriving instance Read Extension - --- Partial display of DynFlags contents, for testing purposes -showDynFlags :: DynFlags -> String -showDynFlags df = - showSDocUnsafe . vcat . map (\(n, d) -> text (n ++ ": ") <+> d) $ - [ ("extensions", ppr . extensions $ df) - , ("extensionFlags", ppr . EnumSet.toList . extensionFlags $ df) - , ("importPaths", vList $ importPaths df) - , ("generalFlags", pprHsString . fromString . show . EnumSet.toList . generalFlags $ df) - , -- , ("includePaths", text . show $ includePaths df) - -- ("packageEnv", ppr $ packageEnv df) - ("pkgNames", vcat . map text $ pkgNames df) - , ("packageFlags", vcat . map ppr $ packageFlags df) - -- ,("pkgDatabase",(map) (ppr . installedPackageId) . pkgDatabase $ df) - -- ("pkgDatabase", text . show <$> pkgDatabase $ df) - ] - -vList :: [String] -> SDoc -vList = vcat . map text +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# OPTIONS_GHC -fno-warn-unused-imports -Wno-orphans #-} + +-- |GHC API utilities +module Ide.Plugin.Eval.GHC ( + addExtension, + addImport, + hasPackage, + addPackages, + modifyFlags, + showDynFlags, +) where + +import Data.List (isPrefixOf) +import Data.Maybe (mapMaybe) +import Data.String (fromString) +import Development.IDE.GHC.Compat +import qualified EnumSet +import GHC.LanguageExtensions.Type (Extension (..)) +import GhcMonad (modifySession) +import GhcPlugins (DefUnitId (..), + InstalledUnitId (..), fsLit, + hsc_IC, pprHsString) +import HscTypes (InteractiveContext (ic_dflags)) +import Ide.Plugin.Eval.Util (asS, gStrictTry) +import qualified Lexer +import Module (UnitId (DefiniteUnitId)) +import Outputable (Outputable (ppr), SDoc, + showSDocUnsafe, text, vcat, (<+>)) +import qualified Parser +import SrcLoc (mkRealSrcLoc) +import StringBuffer (stringToStringBuffer) + +{- $setup +>>> import GHC +>>> import GHC.Paths +>>> run act = runGhc (Just libdir) (getInteractiveDynFlags >>= act) +>>> libdir +"/Users/titto/.ghcup/ghc/8.8.4/lib/ghc-8.8.4" +-} + +{- | True if specified package is present in DynFlags + +-- >>> hasPackageTst pkg = run $ \df -> return (hasPackage df pkg) +>>> hasPackageTst pkg = run $ \_ -> addPackages [pkg] >>= return . either Left (\df -> Right (hasPackage df pkg)) + +>>> hasPackageTst "base" +Right True + +>>> hasPackageTst "ghc" +Right True + +>>> hasPackageTst "extra" +Left ": cannot satisfy -package extra\n (use -v for more information)" + +>>> hasPackageTst "QuickCheck" +Left ": cannot satisfy -package QuickCheck\n (use -v for more information)" +-} +hasPackage :: DynFlags -> String -> Bool +hasPackage df = hasPackage_ (packageFlags df) + +hasPackage_ :: [PackageFlag] -> [Char] -> Bool +hasPackage_ pkgFlags name = any (name `isPrefixOf`) (pkgNames_ pkgFlags) + +{- | +>>> run (return . pkgNames) +[] +-} +pkgNames :: DynFlags -> [String] +pkgNames = pkgNames_ . packageFlags + +pkgNames_ :: [PackageFlag] -> [String] +pkgNames_ = + mapMaybe + ( \case + ExposePackage _ (PackageArg n) _ -> Just n + ExposePackage _ (UnitIdArg (DefiniteUnitId n)) _ -> Just $ asS n + _ -> Nothing + ) + +{- | Expose a list of packages. +>>> addPackagesTest pkgs = run (\_ -> (packageFlags <$>) <$> addPackages pkgs) + +>>> addPackagesTest [] +Right [] + +>>> addPackagesTest ["base","base","array"] +Right [-package base{package base True ([])},-package array{package array True ([])}] + +>>> addPackagesTest ["Cabal"] +Right [-package Cabal{package Cabal True ([])}] + +>>> addPackagesTest ["QuickCheck"] +Left ": cannot satisfy -package QuickCheck\n (use -v for more information)" + +>>> addPackagesTest ["base","notThere"] +Left ": cannot satisfy -package notThere\n (use -v for more information)" + +prop> \(x::Int) -> x + x == 2 * x ++++ OK, passed 100 tests. +-} +addPackages :: [String] -> Ghc (Either String DynFlags) +addPackages pkgNames = gStrictTry $ + modifyFlags $ \df -> + df{packageFlags = foldr (\pkgName pf -> if hasPackage_ pf pkgName then pf else expose pkgName : pf) (packageFlags df) pkgNames} + where + expose name = ExposePackage ("-package " ++ name) (PackageArg name) (ModRenaming True []) + +modifyFlags :: GhcMonad m => (DynFlags -> DynFlags) -> m DynFlags +modifyFlags f = do + df <- getSessionDynFlags + _ <- setSessionDynFlags (f df) + getSessionDynFlags + +-- modifyFlags f = do +-- modifyDynFlags f +-- getSessionDynFlags + +{- | Add import to evaluation context + +>>> run $ \_ -> addImport "import Data.Maybe" +Could not find module ‘Data.Maybe’ +Use -v (or `:set -v` in ghci) to see a list of the files searched for. + +>>> run $ \df -> addPackages ["base"] >> addImport "import Data.Maybe" +[import Data.Maybe] + +>>> run $ \df -> addPackages ["base"] >> addImport "import qualified Data.Maybe as M" +[import qualified Data.Maybe as M] +-} +addImport :: GhcMonad m => String -> m [InteractiveImport] +addImport i = do + ctx <- getContext + -- dbgO "CONTEXT" ctx + idecl <- parseImportDecl i + setContext $ IIDecl idecl : ctx + -- ctx' <- getContext + -- dbg "CONTEXT'" ctx' + getContext + +{- | Add extension to interactive evaluation session +>>> import GHC.LanguageExtensions.Type(Extension(..)) +>>> run $ \_ -> addExtension DeriveGeneric +() +-} +addExtension :: GhcMonad m => Extension -> m () +addExtension ext = + modifySession $ \hsc -> hsc{hsc_IC = setExtension (hsc_IC hsc) ext} + +setExtension :: InteractiveContext -> Extension -> InteractiveContext +setExtension ic ext = ic{ic_dflags = xopt_set (ic_dflags ic) ext} + +deriving instance Read Extension + +-- Partial display of DynFlags contents, for testing purposes +showDynFlags :: DynFlags -> String +showDynFlags df = + showSDocUnsafe . vcat . map (\(n, d) -> text (n ++ ": ") <+> d) $ + [ ("extensions", ppr . extensions $ df) + , ("extensionFlags", ppr . EnumSet.toList . extensionFlags $ df) + , ("importPaths", vList $ importPaths df) + , ("generalFlags", pprHsString . fromString . show . EnumSet.toList . generalFlags $ df) + , -- , ("includePaths", text . show $ includePaths df) + -- ("packageEnv", ppr $ packageEnv df) + ("pkgNames", vcat . map text $ pkgNames df) + , ("packageFlags", vcat . map ppr $ packageFlags df) + -- ,("pkgDatabase",(map) (ppr . installedPackageId) . pkgDatabase $ df) + -- ("pkgDatabase", text . show <$> pkgDatabase $ df) + ] + +vList :: [String] -> SDoc +vList = vcat . map text diff --git a/src/Ide/Plugin/Eval/Parse/Comments.hs b/src/Ide/Plugin/Eval/Parse/Comments.hs --- a/src/Ide/Plugin/Eval/Parse/Comments.hs +++ b/src/Ide/Plugin/Eval/Parse/Comments.hs @@ -1,575 +1,571 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TupleSections #-} - -module Ide.Plugin.Eval.Parse.Comments where - -import qualified Control.Applicative.Combinators.NonEmpty as NE -import Control.Arrow (first, (&&&), (>>>)) -import Control.Lens (lensField, lensRules, view, (.~), (^.)) -import Control.Lens.Extras (is) -import Control.Lens.TH (makeLensesWith, makePrisms, mappingNamer) -import Control.Monad (guard, void, when) -import Control.Monad.Combinators () -import Control.Monad.Reader (ask) -import Control.Monad.Trans.Reader (Reader, runReader) -import qualified Data.Char as C -import qualified Data.DList as DL -import qualified Data.Foldable as F -import Data.Function ((&)) -import Data.Functor.Identity -import Data.List.NonEmpty (NonEmpty ((:|))) -import qualified Data.List.NonEmpty as NE -import Data.Map.Strict (Map) -import qualified Data.Map.Strict as Map -import Data.Void (Void) -import Development.IDE (Position, Range (Range)) -import Development.IDE.Types.Location (Position (..)) -import GHC.Generics -import Ide.Plugin.Eval.Types -import Language.LSP.Types.Lens - ( character, - end, - line, - start, - ) -import Text.Megaparsec -import qualified Text.Megaparsec as P -import Text.Megaparsec.Char - ( alphaNumChar, - char, - eol, - hspace, - letterChar, - ) -import Data.Functor ((<&>)) -import qualified Data.Text as T - -{- -We build parsers combining the following three kinds of them: - - * Line parser - paring a single line into an input, - works both for line- and block-comments. - A line should be a proper content of lines contained in comment: - doesn't include starting @--@ and @{\-@ and no ending @-\}@ - - * Line comment group parser: parses a contiguous group of - tuples of position and line comment into sections of line comments. - Each input MUST start with @--@. - - * Block comment parser: Parsing entire block comment into sections. - Input must be surrounded by @{\-@ and @-\}@. --} - --- | Line parser -type LineParser a = forall m. Monad m => ParsecT Void String m a - --- | Line comment group parser -type LineGroupParser = Parsec Void [(Range, RawLineComment)] - -data BlockEnv = BlockEnv - { isLhs :: Bool - , blockRange :: Range - } - deriving (Read, Show, Eq, Ord) - -makeLensesWith - (lensRules & lensField .~ mappingNamer (pure . (++ "L"))) - ''BlockEnv - --- | Block comment parser -type BlockCommentParser = ParsecT Void String (Reader BlockEnv) - --- | Prop line, with "prop>" stripped off -newtype PropLine = PropLine {getPropLine :: String} - deriving (Show) - --- | Example line, with @>>>@ stripped off -newtype ExampleLine = ExampleLine {getExampleLine :: String} - deriving (Show) - -data TestComment - = AProp - { testCommentRange :: Range - , lineProp :: PropLine - , propResults :: [String] - } - | AnExample - { testCommentRange :: Range - , lineExamples :: NonEmpty ExampleLine - , exampleResults :: [String] - } - deriving (Show) - --- | Classification of comments -data CommentFlavour = Vanilla | HaddockNext | HaddockPrev | Named String - deriving (Read, Show, Eq, Ord) - --- | Single line or block comments? -data CommentStyle = Line | Block Range - deriving (Read, Show, Eq, Ord, Generic) - -makePrisms ''CommentStyle - -commentsToSections :: - -- | True if it is literate Haskell - Bool -> - Comments -> - Sections -commentsToSections isLHS Comments {..} = - let (lineSectionSeeds, lineSetupSeeds) = - foldMap - ( \lcs -> - let theRan = - Range - (view start $ fst $ NE.head lcs) - (view end $ fst $ NE.last lcs) - in case parseMaybe lineGroupP $ NE.toList lcs of - Nothing -> mempty - Just (mls, rs) -> - ( maybe mempty (uncurry Map.singleton) ((theRan,) <$> mls) - , -- orders setup sections in ascending order - if null rs - then mempty - else - Map.singleton theRan $ - DL.singleton (Line, rs) - ) - ) - $ groupLineComments $ - Map.filterWithKey - -- FIXME: - -- To comply with the initial behaviour of - -- Extended Eval Plugin; - -- but it also rejects modules with - -- non-zero base indentation level! - ( \pos _ -> - if isLHS - then pos ^. start . character == 2 - else pos ^. start . character == 0 - ) - lineComments - (blockSeed, blockSetupSeeds) = - foldMap - ( \(ran, lcs) -> - case parseBlockMaybe isLHS ran blockCommentBP $ - getRawBlockComment lcs of - Nothing -> mempty - Just (Named "setup", grp) -> - -- orders setup sections in ascending order - ( mempty - , Map.singleton ran $ - DL.singleton (Block ran, grp) - ) - Just grp -> - ( Map.singleton ran grp - , mempty - ) - ) - -- It seems Extended Eval Plugin doesn't constraint - -- starting indentation level for block comments. - -- Rather, it constrains the indentation level /inside/ - -- block comment body. - $ Map.toList blockComments - lineSections = - lineSectionSeeds <&> uncurry (testsToSection Line) - multilineSections = - Map.mapWithKey - (uncurry . testsToSection . Block) - blockSeed - setupSections = - -- Setups doesn't need Dummy position - map - ( \(style, tests) -> - testsToSection - style - (Named "setup") - tests - ) - $ DL.toList $ - F.fold $ - Map.unionWith (<>) lineSetupSeeds blockSetupSeeds - nonSetupSections = F.toList $ lineSections `Map.union` multilineSections - in Sections {..} - -parseBlockMaybe :: Bool -> Range -> BlockCommentParser a -> String -> Maybe a -parseBlockMaybe isLhs blockRange p i = - case runReader (runParserT p' "" i) BlockEnv {..} of - Left {} -> Nothing - Right a -> Just a - where - p' = do - updateParserState $ \st -> - st - { statePosState = - (statePosState st) - { pstateSourcePos = positionToSourcePos $ blockRange ^. start - } - } - p - -type CommentRange = Range - -type SectionRange = Range - -testsToSection :: - CommentStyle -> - CommentFlavour -> - [TestComment] -> - Section -testsToSection style flav tests = - let sectionName - | Named name <- flav = name - | otherwise = "" - sectionLanguage = case flav of - HaddockNext -> Haddock - HaddockPrev -> Haddock - _ -> Plain - sectionTests = map fromTestComment tests - sectionFormat = - case style of - Line -> SingleLine - Block ran -> MultiLine ran - in Section {..} - -fromTestComment :: TestComment -> Test -fromTestComment AProp {..} = - Property - { testline = getPropLine lineProp - , testOutput = propResults - , testRange = testCommentRange - } -fromTestComment AnExample {..} = - Example - { testLines = getExampleLine <$> lineExamples - , testOutput = exampleResults - , testRange = testCommentRange - } - --- * Block comment parser - -{- $setup ->>> dummyPos = Position 0 0 ->>> parseE p = either (error . errorBundlePretty) id . parse p "" --} - --- >>> parseE (blockCommentBP True dummyPos) "{- |\n >>> 5+5\n 11\n -}" --- (HaddockNext,[AnExample {testCommentRange = Position {_line = 1, _character = 0}, lineExamples = ExampleLine {getExampleLine = " 5+5"} :| [], exampleResults = [" 11"]}]) - -blockCommentBP :: - -- | True if Literate Haskell - BlockCommentParser (CommentFlavour, [TestComment]) -blockCommentBP = do - skipCount 2 anySingle -- "{-" - void $ optional $ char ' ' - flav <- commentFlavourP - hit <- skipNormalCommentBlock - if hit - then do - body <- - many $ - (blockExamples <|> blockProp) - <* skipNormalCommentBlock - void takeRest -- just consume the rest - pure (flav, body) - else pure (flav, []) - -skipNormalCommentBlock :: BlockCommentParser Bool -skipNormalCommentBlock = do - BlockEnv {..} <- ask - skipManyTill (normalLineP isLhs $ Block blockRange) $ - False <$ try (optional (chunk "-}") *> eof) - <|> True <$ lookAhead (try $ testSymbol isLhs $ Block blockRange) - -testSymbol :: Bool -> CommentStyle -> LineParser () -testSymbol isLHS style = - -- FIXME: To comply with existing Extended Eval Plugin Behaviour; - -- it must skip one space after a comment! - -- This prevents Eval Plugin from working on - -- modules with non-standard base indentation-level. - when (isLHS && is _Block style) (void $ count' 0 2 $ char ' ') - *> (exampleSymbol <|> propSymbol) - -eob :: LineParser () -eob = eof <|> try (optional (chunk "-}") *> eof) <|> void eol - -blockExamples - , blockProp :: - BlockCommentParser TestComment -blockExamples = do - BlockEnv {..} <- ask - (ran, examples) <- withRange $ NE.some $ exampleLineStrP isLhs $ Block blockRange - AnExample ran examples <$> resultBlockP -blockProp = do - BlockEnv {..} <- ask - (ran, Identity prop) <- withRange $ fmap Identity $ propLineStrP isLhs $ Block blockRange - AProp ran prop <$> resultBlockP - -withRange :: - (TraversableStream s, Stream s, Monad m, Ord v, Traversable t) => - ParsecT v s m (t (a, Position)) -> - ParsecT v s m (Range, t a) -withRange p = do - beg <- sourcePosToPosition <$> getSourcePos - as <- p - let fin - | null as = beg - | otherwise = snd $ last $ F.toList as - pure (Range beg fin, fst <$> as) - -resultBlockP :: BlockCommentParser [String] -resultBlockP = do - BlockEnv {..} <- ask - many $ - fmap fst . nonEmptyNormalLineP isLhs $ - Block blockRange - -positionToSourcePos :: Position -> SourcePos -positionToSourcePos pos = - P.SourcePos - { sourceName = "" - , sourceLine = P.mkPos $ 1 + pos ^. line - , sourceColumn = P.mkPos $ 1 + pos ^. character - } - -sourcePosToPosition :: SourcePos -> Position -sourcePosToPosition SourcePos {..} = - Position (unPos sourceLine - 1) (unPos sourceColumn - 1) - --- * Line Group Parser - -{- | -Result: a tuple of ordinary line tests and setting sections. - -TODO: Haddock comment can adjacent to vanilla comment: - - @ - -- Vanilla comment - -- Another vanilla - -- | This parses as Haddock comment as GHC - @ - -This behaviour is not yet handled correctly in Eval Plugin; -but for future extension for this, we use a tuple here instead of 'Either'. --} -lineGroupP :: - LineGroupParser - (Maybe (CommentFlavour, [TestComment]), [TestComment]) -lineGroupP = do - (_, flav) <- lookAhead $ parseLine (commentFlavourP <* takeRest) - case flav of - Named "setup" -> (Nothing,) <$> lineCommentSectionsP - flav -> (,mempty) . Just . (flav,) <$> lineCommentSectionsP - --- >>> parse (lineGroupP <*eof) "" $ (dummyPosition, ) . RawLineComment <$> ["-- a", "-- b"] --- Variable not in scope: dummyPosition :: Position - -commentFlavourP :: LineParser CommentFlavour -commentFlavourP = - P.option - Vanilla - ( HaddockNext <$ char '|' - <|> HaddockPrev <$ char '^' - <|> Named <$ char '$' - <* optional hspace - <*> ((:) <$> letterChar <*> P.many alphaNumChar) - ) - <* optional (char ' ') - -lineCommentHeadP :: LineParser () -lineCommentHeadP = do - -- and no operator symbol character follows. - void $ chunk "--" - skipMany $ char '-' - void $ optional $ char ' ' - -lineCommentSectionsP :: - LineGroupParser [TestComment] -lineCommentSectionsP = do - skipMany normalLineCommentP - many $ - exampleLinesGP - <|> uncurry AProp <$> propLineGP <*> resultLinesP - <* skipMany normalLineCommentP - -lexemeLine :: LineGroupParser a -> LineGroupParser a -lexemeLine p = p <* skipMany normalLineCommentP - -resultLinesP :: LineGroupParser [String] -resultLinesP = many nonEmptyLGP - -normalLineCommentP :: LineGroupParser (Range, String) -normalLineCommentP = - parseLine (fst <$ commentFlavourP <*> normalLineP False Line) - -nonEmptyLGP :: LineGroupParser String -nonEmptyLGP = - try $ - fmap snd $ - parseLine $ - fst <$ commentFlavourP <*> nonEmptyNormalLineP False Line - -exampleLinesGP :: LineGroupParser TestComment -exampleLinesGP = - lexemeLine $ - uncurry AnExample . first convexHullRange . NE.unzip - <$> NE.some exampleLineGP - <*> resultLinesP - -convexHullRange :: NonEmpty Range -> Range -convexHullRange nes = - Range (NE.head nes ^. start) (NE.last nes ^. end) - -exampleLineGP :: LineGroupParser (Range, ExampleLine) -exampleLineGP = - -- In line-comments, indentation-level inside comment doesn't matter. - parseLine (fst <$ commentFlavourP <*> exampleLineStrP False Line) - -propLineGP :: LineGroupParser (Range, PropLine) -propLineGP = - -- In line-comments, indentation-level inside comment doesn't matter. - parseLine (fst <$ commentFlavourP <*> propLineStrP False Line) - -{- | -Turning a line parser into line group parser consuming a single line comment. -Parses a sinlge line comment, skipping prefix "--[-*]" with optional one horizontal space. -fails if the input does not start with "--". - -__N.B.__ We don't strip comment flavours. - ->>> pck = (:[]).(:[]) . RawLineComment - ->>> parseMaybe (parseLine $ takeRest) $ pck "-- >>> A" -Just [">>> A"] - ->>> parseMaybe (parseLine $ takeRest) $ pck "--- >>> A" -Just [" >>> A"] - ->>> parseMaybe (parseLine takeRest) $ pck "" -Nothing --} -parseLine :: - (Ord (f RawLineComment), Traversable f) => - LineParser a -> - Parsec Void [f RawLineComment] (f a) -parseLine p = - P.token - (mapM $ parseMaybe (lineCommentHeadP *> p) . getRawLineComment) - mempty - --- * Line Parsers - --- | Non-empty normal line. -nonEmptyNormalLineP :: - -- | True if Literate Haskell - Bool -> - CommentStyle -> - LineParser (String, Position) -nonEmptyNormalLineP isLHS style = try $ do - (ln, pos) <- normalLineP isLHS style - guard $ - case style of - Block{} -> T.strip (T.pack ln) `notElem` ["{-", "-}", ""] - _ -> not $ all C.isSpace ln - pure (ln, pos) - -{- | Normal line is a line neither a example nor prop. - Empty line is normal. --} -normalLineP :: - -- | True if Literate Haskell - Bool -> - CommentStyle -> - LineParser (String, Position) -normalLineP isLHS style = do - notFollowedBy - (try $ testSymbol isLHS style) - when (isLHS && is _Block style) $ - void $ count' 0 2 $ char ' ' - consume style - -consume :: CommentStyle -> LineParser (String, Position) -consume style = - case style of - Line -> (,) <$> takeRest <*> getPosition - Block {} -> manyTill_ anySingle (getPosition <* eob) - -getPosition :: (Ord v, TraversableStream s) => ParsecT v s m Position -getPosition = sourcePosToPosition <$> getSourcePos - --- | Parses example test line. -exampleLineStrP :: - -- | True if Literate Haskell - Bool -> - CommentStyle -> - LineParser (ExampleLine, Position) -exampleLineStrP isLHS style = - try $ - -- FIXME: To comply with existing Extended Eval Plugin Behaviour; - -- it must skip one space after a comment! - -- This prevents Eval Plugin from working on - -- modules with non-standard base indentation-level. - when (isLHS && is _Block style) (void $ count' 0 2 $ char ' ') - *> exampleSymbol - *> (first ExampleLine <$> consume style) - -exampleSymbol :: LineParser () -exampleSymbol = - chunk ">>>" *> P.notFollowedBy (char '>') - -propSymbol :: LineParser () -propSymbol = chunk "prop>" *> P.notFollowedBy (char '>') - --- | Parses prop test line. -propLineStrP :: - -- | True if Literate HAskell - Bool -> - CommentStyle -> - LineParser (PropLine, Position) -propLineStrP isLHS style = - -- FIXME: To comply with existing Extended Eval Plugin Behaviour; - -- it must skip one space after a comment! - -- This prevents Eval Plugin from working on - -- modules with non-standard base indentation-level. - when (isLHS && is _Block style) (void $ count' 0 2 $ char ' ') - *> chunk "prop>" - *> P.notFollowedBy (char '>') - *> (first PropLine <$> consume style) - --- * Utilities - -{- | -Given a sequence of tokens increasing in their starting position, -groups them into sublists consisting of contiguous tokens; -Two adjacent tokens are considered to be contiguous if - - * line number increases by 1, and - * they have same starting column. - ->>> contiguousGroupOn id [(1,2),(2,2),(3,4),(4,4),(5,4),(7,0),(8,0)] -[(1,2) :| [(2,2)],(3,4) :| [(4,4),(5,4)],(7,0) :| [(8,0)]] --} -contiguousGroupOn :: (a -> (Int, Int)) -> [a] -> [NonEmpty a] -contiguousGroupOn toLineCol = foldr step [] - where - step a [] = [pure a] - step a bss0@((b :| bs) : bss) - | let (aLine, aCol) = toLineCol a - , let (bLine, bCol) = toLineCol b - , aLine + 1 == bLine && aCol == bCol = - (a :| b : bs) : bss - | otherwise = pure a : bss0 - -{- | Given a map from positions, divides them into subgroup - with contiguous line and columns. --} -groupLineComments :: - Map Range a -> [NonEmpty (Range, a)] -groupLineComments = - contiguousGroupOn (fst >>> view start >>> view line &&& view character) - . Map.toList +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} + +module Ide.Plugin.Eval.Parse.Comments where + +import qualified Control.Applicative.Combinators.NonEmpty as NE +import Control.Arrow (first, (&&&), (>>>)) +import Control.Lens (lensField, lensRules, + view, (.~), (^.)) +import Control.Lens.Extras (is) +import Control.Lens.TH (makeLensesWith, + makePrisms, + mappingNamer) +import Control.Monad (guard, void, when) +import Control.Monad.Combinators () +import Control.Monad.Reader (ask) +import Control.Monad.Trans.Reader (Reader, runReader) +import qualified Data.Char as C +import qualified Data.DList as DL +import qualified Data.Foldable as F +import Data.Function ((&)) +import Data.Functor ((<&>)) +import Data.Functor.Identity +import Data.List.NonEmpty (NonEmpty ((:|))) +import qualified Data.List.NonEmpty as NE +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import qualified Data.Text as T +import Data.Void (Void) +import Development.IDE (Position, + Range (Range)) +import Development.IDE.Types.Location (Position (..)) +import GHC.Generics +import Ide.Plugin.Eval.Types +import Language.LSP.Types.Lens (character, end, line, + start) +import Text.Megaparsec +import qualified Text.Megaparsec as P +import Text.Megaparsec.Char (alphaNumChar, char, + eol, hspace, + letterChar) + +{- +We build parsers combining the following three kinds of them: + + * Line parser - paring a single line into an input, + works both for line- and block-comments. + A line should be a proper content of lines contained in comment: + doesn't include starting @--@ and @{\-@ and no ending @-\}@ + + * Line comment group parser: parses a contiguous group of + tuples of position and line comment into sections of line comments. + Each input MUST start with @--@. + + * Block comment parser: Parsing entire block comment into sections. + Input must be surrounded by @{\-@ and @-\}@. +-} + +-- | Line parser +type LineParser a = forall m. Monad m => ParsecT Void String m a + +-- | Line comment group parser +type LineGroupParser = Parsec Void [(Range, RawLineComment)] + +data BlockEnv = BlockEnv + { isLhs :: Bool + , blockRange :: Range + } + deriving (Read, Show, Eq, Ord) + +makeLensesWith + (lensRules & lensField .~ mappingNamer (pure . (++ "L"))) + ''BlockEnv + +-- | Block comment parser +type BlockCommentParser = ParsecT Void String (Reader BlockEnv) + +-- | Prop line, with "prop>" stripped off +newtype PropLine = PropLine {getPropLine :: String} + deriving (Show) + +-- | Example line, with @>>>@ stripped off +newtype ExampleLine = ExampleLine {getExampleLine :: String} + deriving (Show) + +data TestComment + = AProp + { testCommentRange :: Range + , lineProp :: PropLine + , propResults :: [String] + } + | AnExample + { testCommentRange :: Range + , lineExamples :: NonEmpty ExampleLine + , exampleResults :: [String] + } + deriving (Show) + +-- | Classification of comments +data CommentFlavour = Vanilla | HaddockNext | HaddockPrev | Named String + deriving (Read, Show, Eq, Ord) + +-- | Single line or block comments? +data CommentStyle = Line | Block Range + deriving (Read, Show, Eq, Ord, Generic) + +makePrisms ''CommentStyle + +commentsToSections :: + -- | True if it is literate Haskell + Bool -> + Comments -> + Sections +commentsToSections isLHS Comments {..} = + let (lineSectionSeeds, lineSetupSeeds) = + foldMap + ( \lcs -> + let theRan = + Range + (view start $ fst $ NE.head lcs) + (view end $ fst $ NE.last lcs) + in case parseMaybe lineGroupP $ NE.toList lcs of + Nothing -> mempty + Just (mls, rs) -> + ( maybe mempty (uncurry Map.singleton) ((theRan,) <$> mls) + , -- orders setup sections in ascending order + if null rs + then mempty + else + Map.singleton theRan $ + DL.singleton (Line, rs) + ) + ) + $ groupLineComments $ + Map.filterWithKey + -- FIXME: + -- To comply with the initial behaviour of + -- Extended Eval Plugin; + -- but it also rejects modules with + -- non-zero base indentation level! + ( \pos _ -> + if isLHS + then pos ^. start . character == 2 + else pos ^. start . character == 0 + ) + lineComments + (blockSeed, blockSetupSeeds) = + foldMap + ( \(ran, lcs) -> + case parseBlockMaybe isLHS ran blockCommentBP $ + getRawBlockComment lcs of + Nothing -> mempty + Just (Named "setup", grp) -> + -- orders setup sections in ascending order + ( mempty + , Map.singleton ran $ + DL.singleton (Block ran, grp) + ) + Just grp -> + ( Map.singleton ran grp + , mempty + ) + ) + -- It seems Extended Eval Plugin doesn't constraint + -- starting indentation level for block comments. + -- Rather, it constrains the indentation level /inside/ + -- block comment body. + $ Map.toList blockComments + lineSections = + lineSectionSeeds <&> uncurry (testsToSection Line) + multilineSections = + Map.mapWithKey + (uncurry . testsToSection . Block) + blockSeed + setupSections = + -- Setups doesn't need Dummy position + map + ( \(style, tests) -> + testsToSection + style + (Named "setup") + tests + ) + $ DL.toList $ + F.fold $ + Map.unionWith (<>) lineSetupSeeds blockSetupSeeds + nonSetupSections = F.toList $ lineSections `Map.union` multilineSections + in Sections {..} + +parseBlockMaybe :: Bool -> Range -> BlockCommentParser a -> String -> Maybe a +parseBlockMaybe isLhs blockRange p i = + case runReader (runParserT p' "" i) BlockEnv {..} of + Left {} -> Nothing + Right a -> Just a + where + p' = do + updateParserState $ \st -> + st + { statePosState = + (statePosState st) + { pstateSourcePos = positionToSourcePos $ blockRange ^. start + } + } + p + +type CommentRange = Range + +type SectionRange = Range + +testsToSection :: + CommentStyle -> + CommentFlavour -> + [TestComment] -> + Section +testsToSection style flav tests = + let sectionName + | Named name <- flav = name + | otherwise = "" + sectionLanguage = case flav of + HaddockNext -> Haddock + HaddockPrev -> Haddock + _ -> Plain + sectionTests = map fromTestComment tests + sectionFormat = + case style of + Line -> SingleLine + Block ran -> MultiLine ran + in Section {..} + +fromTestComment :: TestComment -> Test +fromTestComment AProp {..} = + Property + { testline = getPropLine lineProp + , testOutput = propResults + , testRange = testCommentRange + } +fromTestComment AnExample {..} = + Example + { testLines = getExampleLine <$> lineExamples + , testOutput = exampleResults + , testRange = testCommentRange + } + +-- * Block comment parser + +{- $setup +>>> dummyPos = Position 0 0 +>>> parseE p = either (error . errorBundlePretty) id . parse p "" +-} + +-- >>> parseE (blockCommentBP True dummyPos) "{- |\n >>> 5+5\n 11\n -}" +-- (HaddockNext,[AnExample {testCommentRange = Position {_line = 1, _character = 0}, lineExamples = ExampleLine {getExampleLine = " 5+5"} :| [], exampleResults = [" 11"]}]) + +blockCommentBP :: + -- | True if Literate Haskell + BlockCommentParser (CommentFlavour, [TestComment]) +blockCommentBP = do + skipCount 2 anySingle -- "{-" + void $ optional $ char ' ' + flav <- commentFlavourP + hit <- skipNormalCommentBlock + if hit + then do + body <- + many $ + (blockExamples <|> blockProp) + <* skipNormalCommentBlock + void takeRest -- just consume the rest + pure (flav, body) + else pure (flav, []) + +skipNormalCommentBlock :: BlockCommentParser Bool +skipNormalCommentBlock = do + BlockEnv {..} <- ask + skipManyTill (normalLineP isLhs $ Block blockRange) $ + False <$ try (optional (chunk "-}") *> eof) + <|> True <$ lookAhead (try $ testSymbol isLhs $ Block blockRange) + +testSymbol :: Bool -> CommentStyle -> LineParser () +testSymbol isLHS style = + -- FIXME: To comply with existing Extended Eval Plugin Behaviour; + -- it must skip one space after a comment! + -- This prevents Eval Plugin from working on + -- modules with non-standard base indentation-level. + when (isLHS && is _Block style) (void $ count' 0 2 $ char ' ') + *> (exampleSymbol <|> propSymbol) + +eob :: LineParser () +eob = eof <|> try (optional (chunk "-}") *> eof) <|> void eol + +blockExamples + , blockProp :: + BlockCommentParser TestComment +blockExamples = do + BlockEnv {..} <- ask + (ran, examples) <- withRange $ NE.some $ exampleLineStrP isLhs $ Block blockRange + AnExample ran examples <$> resultBlockP +blockProp = do + BlockEnv {..} <- ask + (ran, Identity prop) <- withRange $ fmap Identity $ propLineStrP isLhs $ Block blockRange + AProp ran prop <$> resultBlockP + +withRange :: + (TraversableStream s, Stream s, Monad m, Ord v, Traversable t) => + ParsecT v s m (t (a, Position)) -> + ParsecT v s m (Range, t a) +withRange p = do + beg <- sourcePosToPosition <$> getSourcePos + as <- p + let fin + | null as = beg + | otherwise = snd $ last $ F.toList as + pure (Range beg fin, fst <$> as) + +resultBlockP :: BlockCommentParser [String] +resultBlockP = do + BlockEnv {..} <- ask + many $ + fmap fst . nonEmptyNormalLineP isLhs $ + Block blockRange + +positionToSourcePos :: Position -> SourcePos +positionToSourcePos pos = + P.SourcePos + { sourceName = "" + , sourceLine = P.mkPos $ 1 + pos ^. line + , sourceColumn = P.mkPos $ 1 + pos ^. character + } + +sourcePosToPosition :: SourcePos -> Position +sourcePosToPosition SourcePos {..} = + Position (unPos sourceLine - 1) (unPos sourceColumn - 1) + +-- * Line Group Parser + +{- | +Result: a tuple of ordinary line tests and setting sections. + +TODO: Haddock comment can adjacent to vanilla comment: + + @ + -- Vanilla comment + -- Another vanilla + -- | This parses as Haddock comment as GHC + @ + +This behaviour is not yet handled correctly in Eval Plugin; +but for future extension for this, we use a tuple here instead of 'Either'. +-} +lineGroupP :: + LineGroupParser + (Maybe (CommentFlavour, [TestComment]), [TestComment]) +lineGroupP = do + (_, flav) <- lookAhead $ parseLine (commentFlavourP <* takeRest) + case flav of + Named "setup" -> (Nothing,) <$> lineCommentSectionsP + flav -> (,mempty) . Just . (flav,) <$> lineCommentSectionsP + +-- >>> parse (lineGroupP <*eof) "" $ (dummyPosition, ) . RawLineComment <$> ["-- a", "-- b"] +-- Variable not in scope: dummyPosition :: Position + +commentFlavourP :: LineParser CommentFlavour +commentFlavourP = + P.option + Vanilla + ( HaddockNext <$ char '|' + <|> HaddockPrev <$ char '^' + <|> Named <$ char '$' + <* optional hspace + <*> ((:) <$> letterChar <*> P.many alphaNumChar) + ) + <* optional (char ' ') + +lineCommentHeadP :: LineParser () +lineCommentHeadP = do + -- and no operator symbol character follows. + void $ chunk "--" + skipMany $ char '-' + void $ optional $ char ' ' + +lineCommentSectionsP :: + LineGroupParser [TestComment] +lineCommentSectionsP = do + skipMany normalLineCommentP + many $ + exampleLinesGP + <|> uncurry AProp <$> propLineGP <*> resultLinesP + <* skipMany normalLineCommentP + +lexemeLine :: LineGroupParser a -> LineGroupParser a +lexemeLine p = p <* skipMany normalLineCommentP + +resultLinesP :: LineGroupParser [String] +resultLinesP = many nonEmptyLGP + +normalLineCommentP :: LineGroupParser (Range, String) +normalLineCommentP = + parseLine (fst <$ commentFlavourP <*> normalLineP False Line) + +nonEmptyLGP :: LineGroupParser String +nonEmptyLGP = + try $ + fmap snd $ + parseLine $ + fst <$ commentFlavourP <*> nonEmptyNormalLineP False Line + +exampleLinesGP :: LineGroupParser TestComment +exampleLinesGP = + lexemeLine $ + uncurry AnExample . first convexHullRange . NE.unzip + <$> NE.some exampleLineGP + <*> resultLinesP + +convexHullRange :: NonEmpty Range -> Range +convexHullRange nes = + Range (NE.head nes ^. start) (NE.last nes ^. end) + +exampleLineGP :: LineGroupParser (Range, ExampleLine) +exampleLineGP = + -- In line-comments, indentation-level inside comment doesn't matter. + parseLine (fst <$ commentFlavourP <*> exampleLineStrP False Line) + +propLineGP :: LineGroupParser (Range, PropLine) +propLineGP = + -- In line-comments, indentation-level inside comment doesn't matter. + parseLine (fst <$ commentFlavourP <*> propLineStrP False Line) + +{- | +Turning a line parser into line group parser consuming a single line comment. +Parses a sinlge line comment, skipping prefix "--[-*]" with optional one horizontal space. +fails if the input does not start with "--". + +__N.B.__ We don't strip comment flavours. + +>>> pck = (:[]).(:[]) . RawLineComment + +>>> parseMaybe (parseLine $ takeRest) $ pck "-- >>> A" +Just [">>> A"] + +>>> parseMaybe (parseLine $ takeRest) $ pck "--- >>> A" +Just [" >>> A"] + +>>> parseMaybe (parseLine takeRest) $ pck "" +Nothing +-} +parseLine :: + (Ord (f RawLineComment), Traversable f) => + LineParser a -> + Parsec Void [f RawLineComment] (f a) +parseLine p = + P.token + (mapM $ parseMaybe (lineCommentHeadP *> p) . getRawLineComment) + mempty + +-- * Line Parsers + +-- | Non-empty normal line. +nonEmptyNormalLineP :: + -- | True if Literate Haskell + Bool -> + CommentStyle -> + LineParser (String, Position) +nonEmptyNormalLineP isLHS style = try $ do + (ln, pos) <- normalLineP isLHS style + guard $ + case style of + Block{} -> T.strip (T.pack ln) `notElem` ["{-", "-}", ""] + _ -> not $ all C.isSpace ln + pure (ln, pos) + +{- | Normal line is a line neither a example nor prop. + Empty line is normal. +-} +normalLineP :: + -- | True if Literate Haskell + Bool -> + CommentStyle -> + LineParser (String, Position) +normalLineP isLHS style = do + notFollowedBy + (try $ testSymbol isLHS style) + when (isLHS && is _Block style) $ + void $ count' 0 2 $ char ' ' + consume style + +consume :: CommentStyle -> LineParser (String, Position) +consume style = + case style of + Line -> (,) <$> takeRest <*> getPosition + Block {} -> manyTill_ anySingle (getPosition <* eob) + +getPosition :: (Ord v, TraversableStream s) => ParsecT v s m Position +getPosition = sourcePosToPosition <$> getSourcePos + +-- | Parses example test line. +exampleLineStrP :: + -- | True if Literate Haskell + Bool -> + CommentStyle -> + LineParser (ExampleLine, Position) +exampleLineStrP isLHS style = + try $ + -- FIXME: To comply with existing Extended Eval Plugin Behaviour; + -- it must skip one space after a comment! + -- This prevents Eval Plugin from working on + -- modules with non-standard base indentation-level. + when (isLHS && is _Block style) (void $ count' 0 2 $ char ' ') + *> exampleSymbol + *> (first ExampleLine <$> consume style) + +exampleSymbol :: LineParser () +exampleSymbol = + chunk ">>>" *> P.notFollowedBy (char '>') + +propSymbol :: LineParser () +propSymbol = chunk "prop>" *> P.notFollowedBy (char '>') + +-- | Parses prop test line. +propLineStrP :: + -- | True if Literate HAskell + Bool -> + CommentStyle -> + LineParser (PropLine, Position) +propLineStrP isLHS style = + -- FIXME: To comply with existing Extended Eval Plugin Behaviour; + -- it must skip one space after a comment! + -- This prevents Eval Plugin from working on + -- modules with non-standard base indentation-level. + when (isLHS && is _Block style) (void $ count' 0 2 $ char ' ') + *> chunk "prop>" + *> P.notFollowedBy (char '>') + *> (first PropLine <$> consume style) + +-- * Utilities + +{- | +Given a sequence of tokens increasing in their starting position, +groups them into sublists consisting of contiguous tokens; +Two adjacent tokens are considered to be contiguous if + + * line number increases by 1, and + * they have same starting column. + +>>> contiguousGroupOn id [(1,2),(2,2),(3,4),(4,4),(5,4),(7,0),(8,0)] +[(1,2) :| [(2,2)],(3,4) :| [(4,4),(5,4)],(7,0) :| [(8,0)]] +-} +contiguousGroupOn :: (a -> (Int, Int)) -> [a] -> [NonEmpty a] +contiguousGroupOn toLineCol = foldr step [] + where + step a [] = [pure a] + step a bss0@((b :| bs) : bss) + | let (aLine, aCol) = toLineCol a + , let (bLine, bCol) = toLineCol b + , aLine + 1 == bLine && aCol == bCol = + (a :| b : bs) : bss + | otherwise = pure a : bss0 + +{- | Given a map from positions, divides them into subgroup + with contiguous line and columns. +-} +groupLineComments :: + Map Range a -> [NonEmpty (Range, a)] +groupLineComments = + contiguousGroupOn (fst >>> view start >>> view line &&& view character) + . Map.toList diff --git a/src/Ide/Plugin/Eval/Parse/Option.hs b/src/Ide/Plugin/Eval/Parse/Option.hs --- a/src/Ide/Plugin/Eval/Parse/Option.hs +++ b/src/Ide/Plugin/Eval/Parse/Option.hs @@ -1,40 +1,40 @@ -{-# OPTIONS_GHC -Wwarn #-} - --- | GHC language options parser -module Ide.Plugin.Eval.Parse.Option ( - langOptions, - parseSetFlags, -) where - -import Text.Megaparsec.Char -import Text.Megaparsec -import Data.Void (Void) -import Control.Arrow (left) - -{- | ->>> langOptions ":set -XBinaryLiterals -XOverloadedStrings " -Right ["BinaryLiterals","OverloadedStrings"] - ->>> langOptions ":set" -Right [] - ->>> langOptions "" -Left "No match" --} -langOptions :: String -> Either String [String] -langOptions = - left errorBundlePretty - . parse (space *> languageOpts <* eof) "" - -parseSetFlags :: String -> Maybe String -parseSetFlags = parseMaybe - (hspace *> chunk ":set" - *> hspace1 *> takeRest - :: Parsec Void String String - ) - --- >>> parseMaybe languageOpts ":set -XBinaryLiterals -XOverloadedStrings" --- Just ["BinaryLiterals","OverloadedStrings"] -languageOpts :: Parsec Void String [String] -languageOpts = string ":set" *> space1 - *> many (string "-X" *> many letterChar <* space) +{-# OPTIONS_GHC -Wwarn #-} + +-- | GHC language options parser +module Ide.Plugin.Eval.Parse.Option ( + langOptions, + parseSetFlags, +) where + +import Control.Arrow (left) +import Data.Void (Void) +import Text.Megaparsec +import Text.Megaparsec.Char + +{- | +>>> langOptions ":set -XBinaryLiterals -XOverloadedStrings " +Right ["BinaryLiterals","OverloadedStrings"] + +>>> langOptions ":set" +Right [] + +>>> langOptions "" +Left "No match" +-} +langOptions :: String -> Either String [String] +langOptions = + left errorBundlePretty + . parse (space *> languageOpts <* eof) "" + +parseSetFlags :: String -> Maybe String +parseSetFlags = parseMaybe + (hspace *> chunk ":set" + *> hspace1 *> takeRest + :: Parsec Void String String + ) + +-- >>> parseMaybe languageOpts ":set -XBinaryLiterals -XOverloadedStrings" +-- Just ["BinaryLiterals","OverloadedStrings"] +languageOpts :: Parsec Void String [String] +languageOpts = string ":set" *> space1 + *> many (string "-X" *> many letterChar <* space) diff --git a/src/Ide/Plugin/Eval/Types.hs b/src/Ide/Plugin/Eval/Types.hs --- a/src/Ide/Plugin/Eval/Types.hs +++ b/src/Ide/Plugin/Eval/Types.hs @@ -1,162 +1,162 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE UndecidableInstances #-} -{-# OPTIONS_GHC -Wwarn #-} - -module Ide.Plugin.Eval.Types - ( locate, - locate0, - Test (..), - isProperty, - Format (..), - Language (..), - Section (..), - Sections (..), - hasTests, - hasPropertyTest, - splitSections, - Loc, - Located (..), - Comments (..), - RawBlockComment (..), - RawLineComment (..), - unLoc, - Txt, - EvalParams(..), - ) -where - -import Control.DeepSeq (NFData (rnf), deepseq) -import Data.Aeson (FromJSON, ToJSON) -import Data.List (partition) -import Data.List.NonEmpty (NonEmpty) -import Data.Map.Strict (Map) -import Data.String (IsString (..)) -import Development.IDE (Range) -import GHC.Generics (Generic) -import qualified Text.Megaparsec as P -import Language.LSP.Types (TextDocumentIdentifier) - --- | A thing with a location attached. -data Located l a = Located {location :: l, located :: a} - deriving (Eq, Show, Ord, Functor, Generic, FromJSON, ToJSON) - --- | Discard location information. -unLoc :: Located l a -> a -unLoc (Located _ a) = a - -instance (NFData l, NFData a) => NFData (Located l a) where - rnf (Located loc a) = loc `deepseq` a `deepseq` () - -type Loc = Located Line - -type Line = Int - -locate :: Loc [a] -> [Loc a] -locate (Located l tst) = zipWith Located [l ..] tst - -locate0 :: [a] -> [Loc a] -locate0 = locate . Located 0 - -type Txt = String - -data Sections = Sections - { nonSetupSections :: [Section] - , setupSections :: [Section] - } - deriving (Show, Eq, Generic) - -data Section = Section - { sectionName :: Txt - , sectionTests :: [Test] - , sectionLanguage :: Language - , sectionFormat :: Format - } - deriving (Eq, Show, Generic, FromJSON, ToJSON, NFData) - -hasTests :: Section -> Bool -hasTests = not . null . sectionTests - -hasPropertyTest :: Section -> Bool -hasPropertyTest = any isProperty . sectionTests - --- |Split setup and normal sections -splitSections :: [Section] -> ([Section], [Section]) -splitSections = partition ((== "setup") . sectionName) - -data Test - = Example {testLines :: NonEmpty Txt, testOutput :: [Txt], testRange :: Range} - | Property {testline :: Txt, testOutput :: [Txt], testRange :: Range} - deriving (Eq, Show, Generic, FromJSON, ToJSON, NFData) - -data Comments = Comments - { lineComments :: Map Range RawLineComment - , blockComments :: Map Range RawBlockComment - } - deriving (Show, Eq, Ord, Generic) - -newtype RawBlockComment = RawBlockComment {getRawBlockComment :: String} - deriving (Show, Eq, Ord) - deriving newtype - ( IsString - , P.Stream - , P.TraversableStream - , P.VisualStream - , Semigroup - , Monoid - ) - -newtype RawLineComment = RawLineComment {getRawLineComment :: String} - deriving (Show, Eq, Ord) - deriving newtype - ( IsString - , P.Stream - , P.TraversableStream - , P.VisualStream - , Semigroup - , Monoid - ) - -instance Semigroup Comments where - Comments ls bs <> Comments ls' bs' = Comments (ls <> ls') (bs <> bs') - -instance Monoid Comments where - mempty = Comments mempty mempty - -isProperty :: Test -> Bool -isProperty Property {} = True -isProperty _ = False - -data Format - = SingleLine - | -- | @Range@ is that of surrounding entire block comment, not section. - -- Used for detecting no-newline test commands. - MultiLine Range - deriving (Eq, Show, Ord, Generic, FromJSON, ToJSON, NFData) - -data Language = Plain | Haddock deriving (Eq, Show, Generic, Ord, FromJSON, ToJSON, NFData) - -data ExpectedLine = ExpectedLine [LineChunk] | WildCardLine - deriving (Eq, Show, Generic, FromJSON, ToJSON, NFData) - -instance IsString ExpectedLine where - fromString = ExpectedLine . return . LineChunk - -data LineChunk = LineChunk String | WildCardChunk - deriving (Eq, Show, Generic, FromJSON, ToJSON, NFData) - -instance IsString LineChunk where - fromString = LineChunk - -type EvalId = Int - --- | Specify the test section to execute -data EvalParams = EvalParams - { sections :: [Section] - , module_ :: !TextDocumentIdentifier - , evalId :: !EvalId -- ^ unique group id; for test uses - } - deriving (Eq, Show, Generic, FromJSON, ToJSON) +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wwarn #-} + +module Ide.Plugin.Eval.Types + ( locate, + locate0, + Test (..), + isProperty, + Format (..), + Language (..), + Section (..), + Sections (..), + hasTests, + hasPropertyTest, + splitSections, + Loc, + Located (..), + Comments (..), + RawBlockComment (..), + RawLineComment (..), + unLoc, + Txt, + EvalParams(..), + ) +where + +import Control.DeepSeq (NFData (rnf), deepseq) +import Data.Aeson (FromJSON, ToJSON) +import Data.List (partition) +import Data.List.NonEmpty (NonEmpty) +import Data.Map.Strict (Map) +import Data.String (IsString (..)) +import Development.IDE (Range) +import GHC.Generics (Generic) +import Language.LSP.Types (TextDocumentIdentifier) +import qualified Text.Megaparsec as P + +-- | A thing with a location attached. +data Located l a = Located {location :: l, located :: a} + deriving (Eq, Show, Ord, Functor, Generic, FromJSON, ToJSON) + +-- | Discard location information. +unLoc :: Located l a -> a +unLoc (Located _ a) = a + +instance (NFData l, NFData a) => NFData (Located l a) where + rnf (Located loc a) = loc `deepseq` a `deepseq` () + +type Loc = Located Line + +type Line = Int + +locate :: Loc [a] -> [Loc a] +locate (Located l tst) = zipWith Located [l ..] tst + +locate0 :: [a] -> [Loc a] +locate0 = locate . Located 0 + +type Txt = String + +data Sections = Sections + { nonSetupSections :: [Section] + , setupSections :: [Section] + } + deriving (Show, Eq, Generic) + +data Section = Section + { sectionName :: Txt + , sectionTests :: [Test] + , sectionLanguage :: Language + , sectionFormat :: Format + } + deriving (Eq, Show, Generic, FromJSON, ToJSON, NFData) + +hasTests :: Section -> Bool +hasTests = not . null . sectionTests + +hasPropertyTest :: Section -> Bool +hasPropertyTest = any isProperty . sectionTests + +-- |Split setup and normal sections +splitSections :: [Section] -> ([Section], [Section]) +splitSections = partition ((== "setup") . sectionName) + +data Test + = Example {testLines :: NonEmpty Txt, testOutput :: [Txt], testRange :: Range} + | Property {testline :: Txt, testOutput :: [Txt], testRange :: Range} + deriving (Eq, Show, Generic, FromJSON, ToJSON, NFData) + +data Comments = Comments + { lineComments :: Map Range RawLineComment + , blockComments :: Map Range RawBlockComment + } + deriving (Show, Eq, Ord, Generic) + +newtype RawBlockComment = RawBlockComment {getRawBlockComment :: String} + deriving (Show, Eq, Ord) + deriving newtype + ( IsString + , P.Stream + , P.TraversableStream + , P.VisualStream + , Semigroup + , Monoid + ) + +newtype RawLineComment = RawLineComment {getRawLineComment :: String} + deriving (Show, Eq, Ord) + deriving newtype + ( IsString + , P.Stream + , P.TraversableStream + , P.VisualStream + , Semigroup + , Monoid + ) + +instance Semigroup Comments where + Comments ls bs <> Comments ls' bs' = Comments (ls <> ls') (bs <> bs') + +instance Monoid Comments where + mempty = Comments mempty mempty + +isProperty :: Test -> Bool +isProperty Property {} = True +isProperty _ = False + +data Format + = SingleLine + | -- | @Range@ is that of surrounding entire block comment, not section. + -- Used for detecting no-newline test commands. + MultiLine Range + deriving (Eq, Show, Ord, Generic, FromJSON, ToJSON, NFData) + +data Language = Plain | Haddock deriving (Eq, Show, Generic, Ord, FromJSON, ToJSON, NFData) + +data ExpectedLine = ExpectedLine [LineChunk] | WildCardLine + deriving (Eq, Show, Generic, FromJSON, ToJSON, NFData) + +instance IsString ExpectedLine where + fromString = ExpectedLine . return . LineChunk + +data LineChunk = LineChunk String | WildCardChunk + deriving (Eq, Show, Generic, FromJSON, ToJSON, NFData) + +instance IsString LineChunk where + fromString = LineChunk + +type EvalId = Int + +-- | Specify the test section to execute +data EvalParams = EvalParams + { sections :: [Section] + , module_ :: !TextDocumentIdentifier + , evalId :: !EvalId -- ^ unique group id; for test uses + } + deriving (Eq, Show, Generic, FromJSON, ToJSON) diff --git a/src/Ide/Plugin/Eval/Util.hs b/src/Ide/Plugin/Eval/Util.hs --- a/src/Ide/Plugin/Eval/Util.hs +++ b/src/Ide/Plugin/Eval/Util.hs @@ -1,116 +1,105 @@ -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE NoMonomorphismRestriction #-} -{-# OPTIONS_GHC -Wno-orphans #-} - --- |Debug utilities -module Ide.Plugin.Eval.Util ( - asS, - timed, - isLiterate, - handleMaybe, - handleMaybeM, - response, - response', - gStrictTry, - logWith, -) where - -import Control.Monad.Extra (maybeM) -import Control.Monad.IO.Class (MonadIO (liftIO)) -import Control.Monad.Trans.Class (lift) -import Control.Monad.Trans.Except ( - ExceptT (..), - runExceptT, - throwE, - ) -import Data.Aeson (Value (Null)) -import Data.Bifunctor (first) -import Data.String (IsString (fromString)) -import qualified Data.Text as T -import Development.IDE ( - IdeState, - Priority (..), - ideLogger, - logPriority, - ) -import Exception (ExceptionMonad, SomeException (..), evaluate, gcatch) -import GHC.Exts (toList) -import GHC.Stack (HasCallStack, callStack, srcLocFile, srcLocStartCol, srcLocStartLine) -import Language.LSP.Server -import Language.LSP.Types -import Outputable ( - Outputable (ppr), - ppr, - showSDocUnsafe, - ) -import System.FilePath (takeExtension) -import System.Time.Extra ( - duration, - showDuration, - ) -import UnliftIO.Exception (catchAny) - -asS :: Outputable a => a -> String -asS = showSDocUnsafe . ppr - -timed :: MonadIO m => (t -> String -> m a) -> t -> m b -> m b -timed out name op = do - (secs, r) <- duration op - _ <- out name (showDuration secs) - return r - --- |Log using hie logger, reports source position of logging statement -logWith :: (HasCallStack, MonadIO m, Show a1, Show a2) => IdeState -> a1 -> a2 -> m () -logWith state key val = - liftIO . logPriority (ideLogger state) logLevel $ - T.unwords - [T.pack logWithPos, asT key, asT val] - where - logWithPos = - let stk = toList callStack - pr pos = concat [srcLocFile pos, ":", show . srcLocStartLine $ pos, ":", show . srcLocStartCol $ pos] - in if null stk then "" else pr . snd . head $ stk - - asT :: Show a => a -> T.Text - asT = T.pack . show - --- | Set to Info to see extensive debug info in hie log, set to Debug in production -logLevel :: Priority -logLevel = Debug -- Info - -isLiterate :: FilePath -> Bool -isLiterate x = takeExtension x `elem` [".lhs", ".lhs-boot"] - -handleMaybe :: Monad m => e -> Maybe b -> ExceptT e m b -handleMaybe msg = maybe (throwE msg) return - -handleMaybeM :: Monad m => e -> m (Maybe b) -> ExceptT e m b -handleMaybeM msg act = maybeM (throwE msg) return $ lift act - -response :: Functor f => ExceptT String f c -> f (Either ResponseError c) -response = - fmap (first (\msg -> ResponseError InternalError (fromString msg) Nothing)) - . runExceptT - -response' :: ExceptT String (LspM c) WorkspaceEdit -> LspM c (Either ResponseError Value) -response' act = do - res <- runExceptT act - `catchAny` showErr - case res of - Left e -> - return $ Left (ResponseError InternalError (fromString e) Nothing) - Right a -> do - _ <- sendRequest SWorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing a) (\_ -> pure ()) - return $ Right Null - -gStrictTry :: ExceptionMonad m => m b -> m (Either String b) -gStrictTry op = - gcatch - (op >>= fmap Right . gevaluate) - showErr - -gevaluate :: MonadIO m => a -> m a -gevaluate = liftIO . evaluate - -showErr :: Monad m => SomeException -> m (Either String b) -showErr = return . Left . show +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +-- |Debug utilities +module Ide.Plugin.Eval.Util ( + asS, + timed, + isLiterate, + handleMaybe, + handleMaybeM, + response, + response', + gStrictTry, + logWith, +) where + +import Control.Monad.Extra (maybeM) +import Control.Monad.IO.Class (MonadIO (liftIO)) +import Control.Monad.Trans.Class (lift) +import Control.Monad.Trans.Except (ExceptT (..), runExceptT, throwE) +import Data.Aeson (Value (Null)) +import Data.Bifunctor (first) +import Data.String (IsString (fromString)) +import qualified Data.Text as T +import Development.IDE (IdeState, Priority (..), ideLogger, + logPriority) +import Exception (ExceptionMonad, SomeException (..), + evaluate, gcatch) +import GHC.Exts (toList) +import GHC.Stack (HasCallStack, callStack, + srcLocFile, srcLocStartCol, + srcLocStartLine) +import Language.LSP.Server +import Language.LSP.Types +import Outputable (Outputable (ppr), ppr, + showSDocUnsafe) +import System.FilePath (takeExtension) +import System.Time.Extra (duration, showDuration) +import UnliftIO.Exception (catchAny) + +asS :: Outputable a => a -> String +asS = showSDocUnsafe . ppr + +timed :: MonadIO m => (t -> String -> m a) -> t -> m b -> m b +timed out name op = do + (secs, r) <- duration op + _ <- out name (showDuration secs) + return r + +-- |Log using hie logger, reports source position of logging statement +logWith :: (HasCallStack, MonadIO m, Show a1, Show a2) => IdeState -> a1 -> a2 -> m () +logWith state key val = + liftIO . logPriority (ideLogger state) logLevel $ + T.unwords + [T.pack logWithPos, asT key, asT val] + where + logWithPos = + let stk = toList callStack + pr pos = concat [srcLocFile pos, ":", show . srcLocStartLine $ pos, ":", show . srcLocStartCol $ pos] + in if null stk then "" else pr . snd . head $ stk + + asT :: Show a => a -> T.Text + asT = T.pack . show + +-- | Set to Info to see extensive debug info in hie log, set to Debug in production +logLevel :: Priority +logLevel = Debug -- Info + +isLiterate :: FilePath -> Bool +isLiterate x = takeExtension x `elem` [".lhs", ".lhs-boot"] + +handleMaybe :: Monad m => e -> Maybe b -> ExceptT e m b +handleMaybe msg = maybe (throwE msg) return + +handleMaybeM :: Monad m => e -> m (Maybe b) -> ExceptT e m b +handleMaybeM msg act = maybeM (throwE msg) return $ lift act + +response :: Functor f => ExceptT String f c -> f (Either ResponseError c) +response = + fmap (first (\msg -> ResponseError InternalError (fromString msg) Nothing)) + . runExceptT + +response' :: ExceptT String (LspM c) WorkspaceEdit -> LspM c (Either ResponseError Value) +response' act = do + res <- runExceptT act + `catchAny` showErr + case res of + Left e -> + return $ Left (ResponseError InternalError (fromString e) Nothing) + Right a -> do + _ <- sendRequest SWorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing a) (\_ -> pure ()) + return $ Right Null + +gStrictTry :: ExceptionMonad m => m b -> m (Either String b) +gStrictTry op = + gcatch + (op >>= fmap Right . gevaluate) + showErr + +gevaluate :: MonadIO m => a -> m a +gevaluate = liftIO . evaluate + +showErr :: Monad m => SomeException -> m (Either String b) +showErr = return . Left . show diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,218 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ViewPatterns #-} + +module Main ( + main, +) where + +import Control.Lens (_Just, preview, view) +import Control.Monad (when) +import Data.Aeson (fromJSON) +import Data.Aeson.Types (Result (Success)) +import Data.List.Extra (nubOrdOn) +import qualified Data.Text as T +import qualified Data.Text.IO as T +import qualified Ide.Plugin.Eval as Eval +import Ide.Plugin.Eval.Types (EvalParams (..)) +import Language.LSP.Types.Lens (command, range, title) +import System.Directory (doesFileExist) +import System.FilePath ((<.>), ()) +import Test.Hls + +main :: IO () +main = defaultTestRunner tests + +evalPlugin :: PluginDescriptor IdeState +evalPlugin = Eval.descriptor "eval" + +tests :: TestTree +tests = + testGroup + "eval" + [ testCase "Produces Evaluate code lenses" $ + runSessionWithServer evalPlugin evalPath $ do + doc <- openDoc "T1.hs" "haskell" + lenses <- getEvalCodeLenses doc + liftIO $ map (preview $ command . _Just . title) lenses @?= [Just "Evaluate..."] + , testCase "Produces Refresh code lenses" $ + runSessionWithServer evalPlugin evalPath $ do + doc <- openDoc "T2.hs" "haskell" + lenses <- getEvalCodeLenses doc + liftIO $ map (preview $ command . _Just . title) lenses @?= [Just "Refresh..."] + , testCase "Code lenses have ranges" $ + runSessionWithServer evalPlugin evalPath $ do + doc <- openDoc "T1.hs" "haskell" + lenses <- getEvalCodeLenses doc + liftIO $ map (view range) lenses @?= [Range (Position 4 0) (Position 5 0)] + , testCase "Multi-line expressions have a multi-line range" $ do + runSessionWithServer evalPlugin evalPath $ do + doc <- openDoc "T3.hs" "haskell" + lenses <- getEvalCodeLenses doc + liftIO $ map (view range) lenses @?= [Range (Position 3 0) (Position 5 0)] + , testCase "Executed expressions range covers only the expression" $ do + runSessionWithServer evalPlugin evalPath $ do + doc <- openDoc "T2.hs" "haskell" + lenses <- getEvalCodeLenses doc + liftIO $ map (view range) lenses @?= [Range (Position 4 0) (Position 5 0)] + , testCase "Evaluation of expressions" $ goldenTest "T1.hs" + , testCase "Reevaluation of expressions" $ goldenTest "T2.hs" + , testCase "Evaluation of expressions w/ imports" $ goldenTest "T3.hs" + , testCase "Evaluation of expressions w/ lets" $ goldenTest "T4.hs" + , testCase "Refresh an evaluation" $ goldenTest "T5.hs" + , testCase "Refresh an evaluation w/ lets" $ goldenTest "T6.hs" + , testCase "Refresh a multiline evaluation" $ goldenTest "T7.hs" + , testCase "Semantic and Lexical errors are reported" $ goldenTest "T8.hs" + , testCase "Applies file LANGUAGE extensions" $ goldenTest "T9.hs" + , testCase "Evaluate a type with :kind!" $ goldenTest "T10.hs" + , testCase "Reports an error for an incorrect type with :kind!" $ + goldenTest "T11.hs" + , testCase "Shows a kind with :kind" $ goldenTest "T12.hs" + , testCase "Reports an error for an incorrect type with :kind" $ + goldenTest "T13.hs" + , testCase "Returns a fully-instantiated type for :type" $ + goldenTest "T14.hs" + , testCase "Returns an uninstantiated type for :type +v, admitting multiple whitespaces around arguments" $ + goldenTest "T15.hs" + , testCase "Returns defaulted type for :type +d, admitting multiple whitespaces around arguments" $ + goldenTest "T16.hs" + , testCase ":type reports an error when given with unknown +x option" $ + goldenTest "T17.hs" + , testCase "Reports an error when given with unknown command" $ + goldenTest "T18.hs" + , testCase "Returns defaulted type for :type +d reflecting the default declaration specified in the >>> prompt" $ + goldenTest "T19.hs" + , expectFailBecause "known issue - see a note in P.R. #361" $ + testCase ":type +d reflects the `default' declaration of the module" $ + goldenTest "T20.hs" + , testCase ":type handles a multilined result properly" $ + goldenTest "T21.hs" + , testCase ":t behaves exactly the same as :type" $ + goldenTest "T22.hs" + , testCase ":type does \"dovetails\" for short identifiers" $ + goldenTest "T23.hs" + , testCase ":kind! treats a multilined result properly" $ + goldenTest "T24.hs" + , testCase ":kind treats a multilined result properly" $ + goldenTest "T25.hs" + , testCase "local imports" $ + goldenTest "T26.hs" + , testCase "Preserves one empty comment line after prompt" $ + goldenTest "T27.hs" + , testCase + "Multi line comments" + $ goldenTest "TMulti.hs" + , testCase + "Multi line comments, with the last test line ends without newline" + $ goldenTest "TEndingMulti.hs" + , testCase + "Evaluate expressions in Plain comments in both single line and multi line format" + $ goldenTest "TPlainComment.hs" + , testCase + "Evaluate expressions in Haddock comments in both single line and multi line format" + $ goldenTest "THaddock.hs" + , testCase "Compare results (for Haddock tests only)" $ + goldenTest "TCompare.hs" + , testCase "Local Modules imports are accessible in a test" $ + goldenTest "TLocalImport.hs" + , -- , testCase "Local Modules can be imported in a test" $ goldenTest "TLocalImportInTest.hs" + expectFailBecause "Unexplained but minor issue" $ + testCase "Setting language option TupleSections" $ + goldenTest "TLanguageOptionsTupleSections.hs" + , testCase ":set accepts ghci flags" $ + goldenTest "TFlags.hs" + , testCase "IO expressions are supported, stdout/stderr output is ignored" $ + goldenTest "TIO.hs" + , testCase "Property checking" $ goldenTest "TProperty.hs" + , testCase + "Prelude has no special treatment, it is imported as stated in the module" + $ goldenTest "TPrelude.hs" + , testCase + "Don't panic on {-# UNPACK #-} pragma" + $ goldenTest "TUNPACK.hs" + , testCase + "Can handle eval inside nested comment properly" + $ goldenTest "TNested.hs" + , testCase "Test on last line insert results correctly" $ do + let mdl = "TLastLine.hs" + -- Write the test file, to make sure that it has no final line return + writeFile (evalPath mdl) "module TLastLine where\n\n-- >>> take 3 [1..]" + goldenTest mdl + , testGroup "with preprocessors" + [ knownBrokenInEnv [HostOS Windows, GhcVer GHC84, GhcVer GHC86] + "CPP eval on Windows and/or GHC <= 8.6 fails for some reasons" $ + testCase "CPP support" $ goldenTest "TCPP.hs" + , knownBrokenForGhcVersions [GHC84, GHC86] + "Preprocessor known to fail on GHC <= 8.6" + $ testCase "Literate Haskell Bird Style" $ goldenTest "TLHS.lhs" + -- , testCase "Literate Haskell LaTeX Style" $ goldenTest "TLHSLateX.lhs" + ] + , testCase "Works with NoImplicitPrelude" + $ goldenTest "TNoImplicitPrelude.hs" + , testCase "Variable 'it' works" + $ goldenTest "TIt.hs" + ] + +goldenTest :: FilePath -> IO () +goldenTest = goldenTestBy isEvalTest + +{- |Execute all CodeLens accepted by 'filter' + Compare results with the contents of corresponding '.expected' file (and creates it, if missing) +-} +goldenTestBy :: (CodeLens -> Bool) -> FilePath -> IO () +goldenTestBy fltr input = runSessionWithServer evalPlugin evalPath $ do + doc <- openDoc input "haskell" + + -- Execute lenses backwards, to avoid affecting their position in the source file + codeLenses <- reverse <$> getCodeLensesBy fltr doc + -- liftIO $ print codeLenses + + -- Execute sequentially, nubbing elements to avoid + -- evaluating the same section with multiple tests + -- more than twice + mapM_ executeCmd + $ nubOrdOn actSectionId [c | CodeLens{_command = Just c} <- codeLenses] + + edited <- replaceUnicodeQuotes <$> documentContents doc + -- liftIO $ T.putStrLn edited + + let expectedFile = input <.> "expected" + + liftIO $ do + -- Write expected file if missing + missingExpected <- not <$> doesFileExist expectedFile + when missingExpected $ T.writeFile expectedFile edited + expected <- T.readFile expectedFile + edited @?= expected + +actSectionId :: Command -> Int +actSectionId Command{_arguments = Just (List [fromJSON -> Success EvalParams{..}])} = evalId +actSectionId _ = error "Invalid CodeLens" + +getEvalCodeLenses :: TextDocumentIdentifier -> Session [CodeLens] +getEvalCodeLenses = getCodeLensesBy isEvalTest + +getCodeLensesBy :: (CodeLens -> Bool) -> TextDocumentIdentifier -> Session [CodeLens] +getCodeLensesBy f doc = filter f <$> getCodeLenses doc + +-- Execute command and wait for result +executeCmd :: Command -> Session () +executeCmd cmd = do + executeCommand cmd + _resp <- skipManyTill anyMessage (message SWorkspaceApplyEdit) + -- liftIO $ print _resp + return () + +-- Execute only Eval tests to avoid interference from other plugins (e.g ghcide:typesignature.add) +isEvalTest :: CodeLens -> Bool +isEvalTest (CodeLens _ (Just (Command _ cmd _)) _) + | ":eval:" `T.isInfixOf` cmd = True +isEvalTest _ = False + +replaceUnicodeQuotes :: T.Text -> T.Text +replaceUnicodeQuotes = T.replace "‘" "'" . T.replace "’" "'" + +evalPath :: FilePath +evalPath = "test" "testdata" diff --git a/test/testdata/T1.hs b/test/testdata/T1.hs new file mode 100644 --- /dev/null +++ b/test/testdata/T1.hs @@ -0,0 +1,7 @@ +module T1 where + +import Data.List (unwords) + +-- >>> unwords example +example :: [String] +example = ["This","is","an","example","of","evaluation"] diff --git a/test/testdata/T1.hs.expected b/test/testdata/T1.hs.expected new file mode 100644 --- /dev/null +++ b/test/testdata/T1.hs.expected @@ -0,0 +1,8 @@ +module T1 where + +import Data.List (unwords) + +-- >>> unwords example +-- "This is an example of evaluation" +example :: [String] +example = ["This","is","an","example","of","evaluation"] diff --git a/test/testdata/T10.hs b/test/testdata/T10.hs new file mode 100644 --- /dev/null +++ b/test/testdata/T10.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE DataKinds, TypeOperators #-} +module T10 where +import GHC.TypeNats ( type (+) ) + +type Dummy = 1 + 1 + +-- >>> type N = 1 +-- >>> type M = 40 +-- >>> :kind! N + M + 1 diff --git a/test/testdata/T10.hs.expected b/test/testdata/T10.hs.expected new file mode 100644 --- /dev/null +++ b/test/testdata/T10.hs.expected @@ -0,0 +1,11 @@ +{-# LANGUAGE DataKinds, TypeOperators #-} +module T10 where +import GHC.TypeNats ( type (+) ) + +type Dummy = 1 + 1 + +-- >>> type N = 1 +-- >>> type M = 40 +-- >>> :kind! N + M + 1 +-- N + M + 1 :: Nat +-- = 42 diff --git a/test/testdata/T11.hs b/test/testdata/T11.hs new file mode 100644 --- /dev/null +++ b/test/testdata/T11.hs @@ -0,0 +1,3 @@ +module T11 where + +-- >>> :kind! a diff --git a/test/testdata/T11.hs.expected b/test/testdata/T11.hs.expected new file mode 100644 --- /dev/null +++ b/test/testdata/T11.hs.expected @@ -0,0 +1,4 @@ +module T11 where + +-- >>> :kind! a +-- Not in scope: type variable 'a' diff --git a/test/testdata/T12.hs b/test/testdata/T12.hs new file mode 100644 --- /dev/null +++ b/test/testdata/T12.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE DataKinds, TypeOperators #-} +module T12 where +import GHC.TypeNats ( type (+) ) + +type Dummy = 1 + 1 + +-- >>> type N = 1 +-- >>> type M = 40 +-- >>> :kind N + M + 1 diff --git a/test/testdata/T12.hs.expected b/test/testdata/T12.hs.expected new file mode 100644 --- /dev/null +++ b/test/testdata/T12.hs.expected @@ -0,0 +1,10 @@ +{-# LANGUAGE DataKinds, TypeOperators #-} +module T12 where +import GHC.TypeNats ( type (+) ) + +type Dummy = 1 + 1 + +-- >>> type N = 1 +-- >>> type M = 40 +-- >>> :kind N + M + 1 +-- N + M + 1 :: Nat diff --git a/test/testdata/T13.hs b/test/testdata/T13.hs new file mode 100644 --- /dev/null +++ b/test/testdata/T13.hs @@ -0,0 +1,3 @@ +module T13 where + +-- >>> :kind a diff --git a/test/testdata/T13.hs.expected b/test/testdata/T13.hs.expected new file mode 100644 --- /dev/null +++ b/test/testdata/T13.hs.expected @@ -0,0 +1,4 @@ +module T13 where + +-- >>> :kind a +-- Not in scope: type variable 'a' diff --git a/test/testdata/T14.hs b/test/testdata/T14.hs new file mode 100644 --- /dev/null +++ b/test/testdata/T14.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE TypeApplications #-} +module T14 where + +foo :: Show a => a -> String +foo = show + +-- >>> :type foo @Int diff --git a/test/testdata/T14.hs.expected b/test/testdata/T14.hs.expected new file mode 100644 --- /dev/null +++ b/test/testdata/T14.hs.expected @@ -0,0 +1,8 @@ +{-# LANGUAGE TypeApplications #-} +module T14 where + +foo :: Show a => a -> String +foo = show + +-- >>> :type foo @Int +-- foo @Int :: Int -> String diff --git a/test/testdata/T15.hs b/test/testdata/T15.hs new file mode 100644 --- /dev/null +++ b/test/testdata/T15.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE TypeApplications #-} +module T15 where + +foo :: Show a => a -> String +foo = show + +-- >>> :type +v foo @Int diff --git a/test/testdata/T15.hs.expected b/test/testdata/T15.hs.expected new file mode 100644 --- /dev/null +++ b/test/testdata/T15.hs.expected @@ -0,0 +1,8 @@ +{-# LANGUAGE TypeApplications #-} +module T15 where + +foo :: Show a => a -> String +foo = show + +-- >>> :type +v foo @Int +-- foo @Int :: Show Int => Int -> String diff --git a/test/testdata/T16.hs b/test/testdata/T16.hs new file mode 100644 --- /dev/null +++ b/test/testdata/T16.hs @@ -0,0 +1,3 @@ +module T16 where + +-- >>> :type +d 40+ 2 diff --git a/test/testdata/T16.hs.expected b/test/testdata/T16.hs.expected new file mode 100644 --- /dev/null +++ b/test/testdata/T16.hs.expected @@ -0,0 +1,4 @@ +module T16 where + +-- >>> :type +d 40+ 2 +-- 40+ 2 :: Integer diff --git a/test/testdata/T17.hs b/test/testdata/T17.hs new file mode 100644 --- /dev/null +++ b/test/testdata/T17.hs @@ -0,0 +1,3 @@ +module T17 where + +-- >>> :type +no 42 diff --git a/test/testdata/T17.hs.expected b/test/testdata/T17.hs.expected new file mode 100644 --- /dev/null +++ b/test/testdata/T17.hs.expected @@ -0,0 +1,4 @@ +module T17 where + +-- >>> :type +no 42 +-- parse error on input '+' diff --git a/test/testdata/T18.hs b/test/testdata/T18.hs new file mode 100644 --- /dev/null +++ b/test/testdata/T18.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE TypeApplications #-} +module T18 where + +-- >>> :noooop foo bar diff --git a/test/testdata/T18.hs.expected b/test/testdata/T18.hs.expected new file mode 100644 --- /dev/null +++ b/test/testdata/T18.hs.expected @@ -0,0 +1,5 @@ +{-# LANGUAGE TypeApplications #-} +module T18 where + +-- >>> :noooop foo bar +-- unknown command 'noooop' diff --git a/test/testdata/T19.hs b/test/testdata/T19.hs new file mode 100644 --- /dev/null +++ b/test/testdata/T19.hs @@ -0,0 +1,6 @@ +module T19 where +import Data.Word (Word) +type W = Word + +-- >>> default (Word) +-- >>> :type +d 40+ 2 diff --git a/test/testdata/T19.hs.expected b/test/testdata/T19.hs.expected new file mode 100644 --- /dev/null +++ b/test/testdata/T19.hs.expected @@ -0,0 +1,7 @@ +module T19 where +import Data.Word (Word) +type W = Word + +-- >>> default (Word) +-- >>> :type +d 40+ 2 +-- 40+ 2 :: Word diff --git a/test/testdata/T2.hs b/test/testdata/T2.hs new file mode 100644 --- /dev/null +++ b/test/testdata/T2.hs @@ -0,0 +1,8 @@ +module T2 where + +import Data.List (unwords) + +-- >>> unwords example +-- "Stale output" +example :: [String] +example = ["This","is","an","example","of","evaluation"] diff --git a/test/testdata/T2.hs.expected b/test/testdata/T2.hs.expected new file mode 100644 --- /dev/null +++ b/test/testdata/T2.hs.expected @@ -0,0 +1,8 @@ +module T2 where + +import Data.List (unwords) + +-- >>> unwords example +-- "This is an example of evaluation" +example :: [String] +example = ["This","is","an","example","of","evaluation"] diff --git a/test/testdata/T20.hs b/test/testdata/T20.hs new file mode 100644 --- /dev/null +++ b/test/testdata/T20.hs @@ -0,0 +1,6 @@ +module T20 where +import Data.Word (Word) + +default (Word) + +-- >>> :type +d 40+ 2 diff --git a/test/testdata/T20.hs.expected b/test/testdata/T20.hs.expected new file mode 100644 --- /dev/null +++ b/test/testdata/T20.hs.expected @@ -0,0 +1,7 @@ +module T20 where +import Data.Word (Word) + +default (Word) + +-- >>> :type +d 40+ 2 +-- 40+ 2 :: Word diff --git a/test/testdata/T21.hs b/test/testdata/T21.hs new file mode 100644 --- /dev/null +++ b/test/testdata/T21.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +module T21 where +import Data.Proxy (Proxy(..)) +import GHC.TypeNats (KnownNat) +import Type.Reflection (Typeable) + +fun :: forall k n a. (KnownNat k, KnownNat n, Typeable a) + => Proxy k -> Proxy n -> Proxy a -> () +fun _ _ _ = () + +-- >>> :type fun diff --git a/test/testdata/T21.hs.expected b/test/testdata/T21.hs.expected new file mode 100644 --- /dev/null +++ b/test/testdata/T21.hs.expected @@ -0,0 +1,16 @@ +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +module T21 where +import Data.Proxy (Proxy(..)) +import GHC.TypeNats (KnownNat) +import Type.Reflection (Typeable) + +fun :: forall k n a. (KnownNat k, KnownNat n, Typeable a) + => Proxy k -> Proxy n -> Proxy a -> () +fun _ _ _ = () + +-- >>> :type fun +-- fun +-- :: forall k1 (k2 :: Nat) (n :: Nat) (a :: k1). +-- (KnownNat k2, KnownNat n, Typeable a) => +-- Proxy k2 -> Proxy n -> Proxy a -> () diff --git a/test/testdata/T22.hs b/test/testdata/T22.hs new file mode 100644 --- /dev/null +++ b/test/testdata/T22.hs @@ -0,0 +1,9 @@ +module T22 where +import Data.Proxy (Proxy (..)) +import GHC.TypeNats (KnownNat) +import Type.Reflection (Typeable) + +f :: Integer +f = 32 + +-- >>> :t f diff --git a/test/testdata/T22.hs.expected b/test/testdata/T22.hs.expected new file mode 100644 --- /dev/null +++ b/test/testdata/T22.hs.expected @@ -0,0 +1,10 @@ +module T22 where +import Data.Proxy (Proxy (..)) +import GHC.TypeNats (KnownNat) +import Type.Reflection (Typeable) + +f :: Integer +f = 32 + +-- >>> :t f +-- f :: Integer diff --git a/test/testdata/T23.hs b/test/testdata/T23.hs new file mode 100644 --- /dev/null +++ b/test/testdata/T23.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +module T23 where +import Data.Proxy (Proxy (..)) +import GHC.TypeNats (KnownNat) +import Type.Reflection (Typeable) + +f :: forall k n a. (KnownNat k, KnownNat n, Typeable a) + => Proxy k -> Proxy n -> Proxy a -> () +f _ _ _ = () + +-- >>> :type f diff --git a/test/testdata/T23.hs.expected b/test/testdata/T23.hs.expected new file mode 100644 --- /dev/null +++ b/test/testdata/T23.hs.expected @@ -0,0 +1,15 @@ +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +module T23 where +import Data.Proxy (Proxy (..)) +import GHC.TypeNats (KnownNat) +import Type.Reflection (Typeable) + +f :: forall k n a. (KnownNat k, KnownNat n, Typeable a) + => Proxy k -> Proxy n -> Proxy a -> () +f _ _ _ = () + +-- >>> :type f +-- f :: forall k1 (k2 :: Nat) (n :: Nat) (a :: k1). +-- (KnownNat k2, KnownNat n, Typeable a) => +-- Proxy k2 -> Proxy n -> Proxy a -> () diff --git a/test/testdata/T24.hs b/test/testdata/T24.hs new file mode 100644 --- /dev/null +++ b/test/testdata/T24.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +module T24 where +import GHC.TypeNats (type (-)) +data Proxy a = Stop | Next (Proxy a) + +type family LongP n a where + LongP 0 a = a + LongP n a = Next (LongP (n - 1) a) + +-- >>> :kind! ((LongP 10 Stop) :: Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy Double))))))))))))) diff --git a/test/testdata/T24.hs.expected b/test/testdata/T24.hs.expected new file mode 100644 --- /dev/null +++ b/test/testdata/T24.hs.expected @@ -0,0 +1,32 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +module T24 where +import GHC.TypeNats (type (-)) +data Proxy a = Stop | Next (Proxy a) + +type family LongP n a where + LongP 0 a = a + LongP n a = Next (LongP (n - 1) a) + +-- >>> :kind! ((LongP 10 Stop) :: Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy Double))))))))))))) +-- ((LongP 10 Stop) :: Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy Double))))))))))))) :: Proxy +-- (Proxy +-- (Proxy +-- (Proxy +-- (Proxy +-- (Proxy +-- (Proxy +-- (Proxy +-- (Proxy +-- (Proxy +-- (Proxy +-- (Proxy +-- (Proxy +-- Double)))))))))))) +-- = 'Next +-- ('Next +-- ('Next +-- ('Next ('Next ('Next ('Next ('Next ('Next ('Next 'Stop))))))))) diff --git a/test/testdata/T25.hs b/test/testdata/T25.hs new file mode 100644 --- /dev/null +++ b/test/testdata/T25.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +module T25 where +import GHC.TypeNats (type (-)) +data Proxy a = Stop | Next (Proxy a) + +type family LongP n a where + LongP 0 a = a + LongP n a = Next (LongP (n - 1) a) + +-- >>> :kind (Stop :: Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy Double))))))))))))) diff --git a/test/testdata/T25.hs.expected b/test/testdata/T25.hs.expected new file mode 100644 --- /dev/null +++ b/test/testdata/T25.hs.expected @@ -0,0 +1,28 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +module T25 where +import GHC.TypeNats (type (-)) +data Proxy a = Stop | Next (Proxy a) + +type family LongP n a where + LongP 0 a = a + LongP n a = Next (LongP (n - 1) a) + +-- >>> :kind (Stop :: Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy Double))))))))))))) +-- (Stop :: Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy Double))))))))))))) :: Proxy +-- (Proxy +-- (Proxy +-- (Proxy +-- (Proxy +-- (Proxy +-- (Proxy +-- (Proxy +-- (Proxy +-- (Proxy +-- (Proxy +-- (Proxy +-- (Proxy +-- Double)))))))))))) diff --git a/test/testdata/T26.hs b/test/testdata/T26.hs new file mode 100644 --- /dev/null +++ b/test/testdata/T26.hs @@ -0,0 +1,4 @@ +module T26 where +import T25 () + +-- >>> "hello" diff --git a/test/testdata/T26.hs.expected b/test/testdata/T26.hs.expected new file mode 100644 --- /dev/null +++ b/test/testdata/T26.hs.expected @@ -0,0 +1,5 @@ +module T26 where +import T25 () + +-- >>> "hello" +-- "hello" diff --git a/test/testdata/T27.hs b/test/testdata/T27.hs new file mode 100644 --- /dev/null +++ b/test/testdata/T27.hs @@ -0,0 +1,4 @@ +module T27 where + +-- >>> () +-- diff --git a/test/testdata/T27.hs.expected b/test/testdata/T27.hs.expected new file mode 100644 --- /dev/null +++ b/test/testdata/T27.hs.expected @@ -0,0 +1,5 @@ +module T27 where + +-- >>> () +-- () +-- diff --git a/test/testdata/T3.hs b/test/testdata/T3.hs new file mode 100644 --- /dev/null +++ b/test/testdata/T3.hs @@ -0,0 +1,7 @@ +module T3 where + + +-- >>> import Data.List (unwords) +-- >>> unwords example +example :: [String] +example = ["This","is","an","example","of","evaluation"] diff --git a/test/testdata/T3.hs.expected b/test/testdata/T3.hs.expected new file mode 100644 --- /dev/null +++ b/test/testdata/T3.hs.expected @@ -0,0 +1,8 @@ +module T3 where + + +-- >>> import Data.List (unwords) +-- >>> unwords example +-- "This is an example of evaluation" +example :: [String] +example = ["This","is","an","example","of","evaluation"] diff --git a/test/testdata/T4.hs b/test/testdata/T4.hs new file mode 100644 --- /dev/null +++ b/test/testdata/T4.hs @@ -0,0 +1,9 @@ +module T4 where + +import Data.List (unwords) + +-- >>> let evaluation = " evaluation" +-- >>> unwords example ++ evaluation +example :: [String] +example = ["This","is","an","example","of"] + diff --git a/test/testdata/T4.hs.expected b/test/testdata/T4.hs.expected new file mode 100644 --- /dev/null +++ b/test/testdata/T4.hs.expected @@ -0,0 +1,10 @@ +module T4 where + +import Data.List (unwords) + +-- >>> let evaluation = " evaluation" +-- >>> unwords example ++ evaluation +-- "This is an example of evaluation" +example :: [String] +example = ["This","is","an","example","of"] + diff --git a/test/testdata/T5.hs b/test/testdata/T5.hs new file mode 100644 --- /dev/null +++ b/test/testdata/T5.hs @@ -0,0 +1,6 @@ +module T5 where + +-- >>> unwords example +-- "This is a stale example of evaluation" +example :: [String] +example = ["This","is","an","example","of","evaluation"] diff --git a/test/testdata/T5.hs.expected b/test/testdata/T5.hs.expected new file mode 100644 --- /dev/null +++ b/test/testdata/T5.hs.expected @@ -0,0 +1,6 @@ +module T5 where + +-- >>> unwords example +-- "This is an example of evaluation" +example :: [String] +example = ["This","is","an","example","of","evaluation"] diff --git a/test/testdata/T6.hs b/test/testdata/T6.hs new file mode 100644 --- /dev/null +++ b/test/testdata/T6.hs @@ -0,0 +1,9 @@ +module T6 where + +import Data.List (unwords) + +-- >>> let evaluation = " evaluation" +-- >>> unwords example ++ evaluation +-- "This is a stale example of evaluation" +example :: [String] +example = ["This","is","an","example","of"] diff --git a/test/testdata/T6.hs.expected b/test/testdata/T6.hs.expected new file mode 100644 --- /dev/null +++ b/test/testdata/T6.hs.expected @@ -0,0 +1,9 @@ +module T6 where + +import Data.List (unwords) + +-- >>> let evaluation = " evaluation" +-- >>> unwords example ++ evaluation +-- "This is an example of evaluation" +example :: [String] +example = ["This","is","an","example","of"] diff --git a/test/testdata/T7.hs b/test/testdata/T7.hs new file mode 100644 --- /dev/null +++ b/test/testdata/T7.hs @@ -0,0 +1,10 @@ +module T7 where + +import Data.List (unwords) + +-- >>> -- +-- >>> -- +-- >>> unwords example +-- "This is a stale example of" +example :: [String] +example = ["This","is","an","example","of"] diff --git a/test/testdata/T7.hs.expected b/test/testdata/T7.hs.expected new file mode 100644 --- /dev/null +++ b/test/testdata/T7.hs.expected @@ -0,0 +1,10 @@ +module T7 where + +import Data.List (unwords) + +-- >>> -- +-- >>> -- +-- >>> unwords example +-- "This is an example of" +example :: [String] +example = ["This","is","an","example","of"] diff --git a/test/testdata/T8.hs b/test/testdata/T8.hs new file mode 100644 --- /dev/null +++ b/test/testdata/T8.hs @@ -0,0 +1,10 @@ +-- Semantic and Lexical errors are reported +module T8 where + +-- >>> noFunctionWithThisName + +-- >>> "a" + "bc" + +-- >>> " + +-- >>> 3 `div` 0 diff --git a/test/testdata/T8.hs.expected b/test/testdata/T8.hs.expected new file mode 100644 --- /dev/null +++ b/test/testdata/T8.hs.expected @@ -0,0 +1,14 @@ +-- Semantic and Lexical errors are reported +module T8 where + +-- >>> noFunctionWithThisName +-- Variable not in scope: noFunctionWithThisName + +-- >>> "a" + "bc" +-- No instance for (Num [Char]) arising from a use of '+' + +-- >>> " +-- lexical error in string/character literal at end of input + +-- >>> 3 `div` 0 +-- divide by zero diff --git a/test/testdata/T9.hs b/test/testdata/T9.hs new file mode 100644 --- /dev/null +++ b/test/testdata/T9.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE DataKinds #-} +module T9 where +import Data.Proxy (Proxy(..)) + +type P = Proxy + +-- >>> Proxy :: Proxy 3 diff --git a/test/testdata/T9.hs.expected b/test/testdata/T9.hs.expected new file mode 100644 --- /dev/null +++ b/test/testdata/T9.hs.expected @@ -0,0 +1,8 @@ +{-# LANGUAGE DataKinds #-} +module T9 where +import Data.Proxy (Proxy(..)) + +type P = Proxy + +-- >>> Proxy :: Proxy 3 +-- Proxy diff --git a/test/testdata/TCPP.hs b/test/testdata/TCPP.hs new file mode 100644 --- /dev/null +++ b/test/testdata/TCPP.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module TCPP where + +-- >>> y +y :: Integer +y = 11 + +#define ALL + +#ifdef ALL +-- >>> 3+y +#else +-- >>> 5+y +#endif + +-- >>> 2+y diff --git a/test/testdata/TCPP.hs.expected b/test/testdata/TCPP.hs.expected new file mode 100644 --- /dev/null +++ b/test/testdata/TCPP.hs.expected @@ -0,0 +1,22 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module TCPP where + +-- >>> y +-- 11 +y :: Integer +y = 11 + +#define ALL + +#ifdef ALL +-- >>> 3+y +-- 14 +#else +-- >>> 5+y +#endif + +-- >>> 2+y +-- 13 diff --git a/test/testdata/TCompare.hs b/test/testdata/TCompare.hs new file mode 100644 --- /dev/null +++ b/test/testdata/TCompare.hs @@ -0,0 +1,12 @@ +module TCompare where + +-- In plain comments, the previous result of an evaluation is simply replaced + +-- >>> 2+2 +-- 5 + +-- In Haddock comments, the previous result of an evaluation is compared with the new one +-- and difference are displayed + +-- | >>> 2+2 +-- 5 diff --git a/test/testdata/TCompare.hs.expected b/test/testdata/TCompare.hs.expected new file mode 100644 --- /dev/null +++ b/test/testdata/TCompare.hs.expected @@ -0,0 +1,13 @@ +module TCompare where + +-- In plain comments, the previous result of an evaluation is simply replaced + +-- >>> 2+2 +-- 4 + +-- In Haddock comments, the previous result of an evaluation is compared with the new one +-- and difference are displayed + +-- | >>> 2+2 +-- WAS 5 +-- NOW 4 diff --git a/test/testdata/TEndingMulti.hs b/test/testdata/TEndingMulti.hs new file mode 100644 --- /dev/null +++ b/test/testdata/TEndingMulti.hs @@ -0,0 +1,6 @@ +module TEndingMulti where + +-- Now trailing doctest is allowed: + +{- >>> 42 +>>> 54-} diff --git a/test/testdata/TEndingMulti.hs.expected b/test/testdata/TEndingMulti.hs.expected new file mode 100644 --- /dev/null +++ b/test/testdata/TEndingMulti.hs.expected @@ -0,0 +1,9 @@ +module TEndingMulti where + +-- Now trailing doctest is allowed: + +{- >>> 42 +>>> 54 +42 +54 +-} diff --git a/test/testdata/TFlags.hs b/test/testdata/TFlags.hs new file mode 100644 --- /dev/null +++ b/test/testdata/TFlags.hs @@ -0,0 +1,68 @@ +-- Support for language options + +{-# LANGUAGE ScopedTypeVariables #-} +module TFlags where + +-- Language options set in the module source (ScopedTypeVariables) +-- also apply to tests so this works fine +-- >>> f = (\(c::Char) -> [c]) + +{- Multiple options can be set with a single `:set` + +>>> :set -XMultiParamTypeClasses -XFlexibleInstances +>>> class Z a b c +-} + +{- + +Options apply only in the section where they are defined (unless they are in the setup section), so this will fail: + +>>> class L a b c +-} + + +{- +Options apply to all tests in the same section after their declaration. + +Not set yet: + +>>> class D + +Now it works: + +>>>:set -XMultiParamTypeClasses +>>> class C + +It still works + +>>> class F +-} + +{- Now -package flag is handled correctly: + +>>> :set -package ghc-prim +>>> import GHC.Prim + +-} + +{- -fprint-* families + +>>> import Data.Proxy +>>> :set -XPolyKinds +>>> :t Proxy +Proxy :: forall k (t :: k). Proxy t + +>>> :set -fprint-explicit-foralls +>>> :t Proxy +Proxy :: forall {k} {t :: k}. Proxy t +-} + +{- Invalid option/flags are reported, but valid ones will be reflected + +>>> :set -XRank2Types -XAbsent -XDatatypeContexts -XWrong -fprint-nothing-at-all + +Still, Rank2Types is enabled, as in GHCi: + +>>> f = const 42 :: (forall x. x) -> Int +>>> f undefined +-} diff --git a/test/testdata/TFlags.hs.expected b/test/testdata/TFlags.hs.expected new file mode 100644 --- /dev/null +++ b/test/testdata/TFlags.hs.expected @@ -0,0 +1,76 @@ +-- Support for language options + +{-# LANGUAGE ScopedTypeVariables #-} +module TFlags where + +-- Language options set in the module source (ScopedTypeVariables) +-- also apply to tests so this works fine +-- >>> f = (\(c::Char) -> [c]) + +{- Multiple options can be set with a single `:set` + +>>> :set -XMultiParamTypeClasses -XFlexibleInstances +>>> class Z a b c +-} + +{- + +Options apply only in the section where they are defined (unless they are in the setup section), so this will fail: + +>>> class L a b c +Too many parameters for class 'L' +(Enable MultiParamTypeClasses to allow multi-parameter classes) +-} + + +{- +Options apply to all tests in the same section after their declaration. + +Not set yet: + +>>> class D +No parameters for class 'D' +(Enable MultiParamTypeClasses to allow no-parameter classes) + +Now it works: + +>>>:set -XMultiParamTypeClasses +>>> class C + +It still works + +>>> class F +-} + +{- Now -package flag is handled correctly: + +>>> :set -package ghc-prim +>>> import GHC.Prim + +-} + +{- -fprint-* families + +>>> import Data.Proxy +>>> :set -XPolyKinds +>>> :t Proxy +Proxy :: forall k (t :: k). Proxy t + +>>> :set -fprint-explicit-foralls +>>> :t Proxy +Proxy :: forall {k} {t :: k}. Proxy t +-} + +{- Invalid option/flags are reported, but valid ones will be reflected + +>>> :set -XRank2Types -XAbsent -XDatatypeContexts -XWrong -fprint-nothing-at-all +: warning: + -XDatatypeContexts is deprecated: It was widely considered a misfeature, and has been removed from the Haskell language. +Some flags have not been recognized: -XAbsent, -XWrong, -fprint-nothing-at-all + +Still, Rank2Types is enabled, as in GHCi: + +>>> f = const 42 :: (forall x. x) -> Int +>>> f undefined +42 +-} diff --git a/test/testdata/THaddock.hs b/test/testdata/THaddock.hs new file mode 100644 --- /dev/null +++ b/test/testdata/THaddock.hs @@ -0,0 +1,35 @@ +{- | +Tests in plain comments in both single line or multi line format, both forward and backward. +Tests are ignored if: + * do not start on the first column (in Ordinary Haskell) + * do not start on the first or second column (in Literate Haskell) +-} +module THaddock () where + +{- ORMOLU_DISABLE -} + +-- | Single line comment +-- >>> "a"++"b" + +{- | Multi line comment + +>>> "b"++"c" +-} + +double a = a + a +-- ^ Single line backward comments +-- >>> double 11 + +twice :: [a] -> [a] +twice a = a ++ a +{- ^ Multi-line backward comments +>>> twice "ABC" +-} + +{- | >>> 2+five + + ^-- This works, as it starts at the first column after the header. + + >>> IGNORED as it does not start on the first column +-} +five = 5 diff --git a/test/testdata/THaddock.hs.expected b/test/testdata/THaddock.hs.expected new file mode 100644 --- /dev/null +++ b/test/testdata/THaddock.hs.expected @@ -0,0 +1,40 @@ +{- | +Tests in plain comments in both single line or multi line format, both forward and backward. +Tests are ignored if: + * do not start on the first column (in Ordinary Haskell) + * do not start on the first or second column (in Literate Haskell) +-} +module THaddock () where + +{- ORMOLU_DISABLE -} + +-- | Single line comment +-- >>> "a"++"b" +-- "ab" + +{- | Multi line comment + +>>> "b"++"c" +"bc" +-} + +double a = a + a +-- ^ Single line backward comments +-- >>> double 11 +-- 22 + +twice :: [a] -> [a] +twice a = a ++ a +{- ^ Multi-line backward comments +>>> twice "ABC" +"ABCABC" +-} + +{- | >>> 2+five +7 + + ^-- This works, as it starts at the first column after the header. + + >>> IGNORED as it does not start on the first column +-} +five = 5 diff --git a/test/testdata/TIO.hs b/test/testdata/TIO.hs new file mode 100644 --- /dev/null +++ b/test/testdata/TIO.hs @@ -0,0 +1,9 @@ +-- IO expressions are supported, stdout/stderr output is ignored +module TIO where + +{- +Does not capture stdout, returns value. + +>>> print "ABC" >> return "XYZ" +"XYZ" +-} diff --git a/test/testdata/TIO.hs.expected b/test/testdata/TIO.hs.expected new file mode 100644 --- /dev/null +++ b/test/testdata/TIO.hs.expected @@ -0,0 +1,9 @@ +-- IO expressions are supported, stdout/stderr output is ignored +module TIO where + +{- +Does not capture stdout, returns value. + +>>> print "ABC" >> return "XYZ" +"XYZ" +-} diff --git a/test/testdata/TIt.hs b/test/testdata/TIt.hs new file mode 100644 --- /dev/null +++ b/test/testdata/TIt.hs @@ -0,0 +1,7 @@ +module TIt where + +-- >>> "test" +-- >>> it + +-- >>> pure "test2" +-- >>> it diff --git a/test/testdata/TIt.hs.expected b/test/testdata/TIt.hs.expected new file mode 100644 --- /dev/null +++ b/test/testdata/TIt.hs.expected @@ -0,0 +1,11 @@ +module TIt where + +-- >>> "test" +-- >>> it +-- "test" +-- "test" + +-- >>> pure "test2" +-- >>> it +-- "test2" +-- "test2" diff --git a/test/testdata/TLHS.lhs b/test/testdata/TLHS.lhs new file mode 100644 --- /dev/null +++ b/test/testdata/TLHS.lhs @@ -0,0 +1,22 @@ +An example LHS + +> {-# LANGUAGE OverloadedStrings #-} + +> module TLHS where + +More comments, here. + +> -- | >>> 2+2 + +> -- | >>> x+a + +> {- | +> >>> 5+5 +> 11 +> -} +> x :: Integer +> x = 3 + +> a :: Integer +> a = 11 + diff --git a/test/testdata/TLHS.lhs.expected b/test/testdata/TLHS.lhs.expected new file mode 100644 --- /dev/null +++ b/test/testdata/TLHS.lhs.expected @@ -0,0 +1,25 @@ +An example LHS + +> {-# LANGUAGE OverloadedStrings #-} + +> module TLHS where + +More comments, here. + +> -- | >>> 2+2 +> -- 4 + +> -- | >>> x+a +> -- 14 + +> {- | +> >>> 5+5 +> WAS 11 +> NOW 10 +> -} +> x :: Integer +> x = 3 + +> a :: Integer +> a = 11 + diff --git a/test/testdata/TLHSLaTeX.lhs b/test/testdata/TLHSLaTeX.lhs new file mode 100644 --- /dev/null +++ b/test/testdata/TLHSLaTeX.lhs @@ -0,0 +1,16 @@ +\documentstyle{article} + +\begin{document} + +\section{Introduction} + +This is a trivial program that prints the first 20 factorials. + +\begin{code} +module TLHSLaTeX where + +-- >>> prod +prod = [ (n, product [1..n]) | n <- [1..3]] +\end{code} + +\end{document} diff --git a/test/testdata/TLHSLateX.lhs.expected b/test/testdata/TLHSLateX.lhs.expected new file mode 100644 --- /dev/null +++ b/test/testdata/TLHSLateX.lhs.expected @@ -0,0 +1,17 @@ +\documentstyle{article} + +\begin{document} + +\section{Introduction} + +This is a trivial program that prints the first 20 factorials. + +\begin{code} +module TLHSLaTeX where + +-- >>> prod +-- [(1,1),(2,2),(3,6)] +prod = [ (n, product [1..n]) | n <- [1..3]] +\end{code} + +\end{document} diff --git a/test/testdata/TLanguageOptionsTupleSections.hs b/test/testdata/TLanguageOptionsTupleSections.hs new file mode 100644 --- /dev/null +++ b/test/testdata/TLanguageOptionsTupleSections.hs @@ -0,0 +1,9 @@ +-- This works fine: {-# LANGUAGE TupleSections #-} +module TLanguageOptionsTupleSection where + +-- Why oh why is this not working? +-- What is special about TupleSections? +-- >>> :set -XTupleSections +-- >>> ("a",) "b" +-- ("a","b") + diff --git a/test/testdata/TLanguageOptionsTupleSections.hs.expected b/test/testdata/TLanguageOptionsTupleSections.hs.expected new file mode 100644 --- /dev/null +++ b/test/testdata/TLanguageOptionsTupleSections.hs.expected @@ -0,0 +1,8 @@ +-- This works fine: {-# LANGUAGE TupleSections #-} +module TLanguageOptionsTupleSection where + +-- Why oh why is this not working? +-- What is special about TupleSections? +-- >>> :set -XTupleSections +-- >>> ("a",) "b" +-- ("a","b") diff --git a/test/testdata/TLastLine.hs b/test/testdata/TLastLine.hs new file mode 100644 --- /dev/null +++ b/test/testdata/TLastLine.hs @@ -0,0 +1,3 @@ +module TLastLine where + +-- >>> take 3 [1..] diff --git a/test/testdata/TLastLine.hs.expected b/test/testdata/TLastLine.hs.expected new file mode 100644 --- /dev/null +++ b/test/testdata/TLastLine.hs.expected @@ -0,0 +1,4 @@ +module TLastLine where + +-- >>> take 3 [1..] +-- [1,2,3] diff --git a/test/testdata/TLocalImport.hs b/test/testdata/TLocalImport.hs new file mode 100644 --- /dev/null +++ b/test/testdata/TLocalImport.hs @@ -0,0 +1,5 @@ +module TLocalImport where + +import qualified Util + +-- >>> Util.tst 11 11 diff --git a/test/testdata/TLocalImport.hs.expected b/test/testdata/TLocalImport.hs.expected new file mode 100644 --- /dev/null +++ b/test/testdata/TLocalImport.hs.expected @@ -0,0 +1,6 @@ +module TLocalImport where + +import qualified Util + +-- >>> Util.tst 11 11 +-- True diff --git a/test/testdata/TLocalImportInTest.hs b/test/testdata/TLocalImportInTest.hs new file mode 100644 --- /dev/null +++ b/test/testdata/TLocalImportInTest.hs @@ -0,0 +1,4 @@ +module TLocalImportInTest where + +-- >>> import qualified Util +-- >>> Util.a diff --git a/test/testdata/TLocalImportInTest.hs.expected b/test/testdata/TLocalImportInTest.hs.expected new file mode 100644 --- /dev/null +++ b/test/testdata/TLocalImportInTest.hs.expected @@ -0,0 +1,5 @@ +module TLocalImportInTest where + +-- >>> import qualified Util +-- >>> Util.a +-- 'a' diff --git a/test/testdata/TMulti.hs b/test/testdata/TMulti.hs new file mode 100644 --- /dev/null +++ b/test/testdata/TMulti.hs @@ -0,0 +1,19 @@ +{- | Multi line comments are parsed correctly. +-} +module TMulti () where + +{- ORMOLU_DISABLE -} + +-- this should work fine if previous multi comment is parsed correctly +-- >>> "a"++"b" + + {- >>> 3+3 + -} + +-- this should work fine if previous multi comment is parsed correctly +-- >>> "a"++"b" + + {-| >>> "NOT IGNORED" -} + +-- this should work fine if previous multi comment is parsed correctly +-- >>> "a"++"b" diff --git a/test/testdata/TMulti.hs.expected b/test/testdata/TMulti.hs.expected new file mode 100644 --- /dev/null +++ b/test/testdata/TMulti.hs.expected @@ -0,0 +1,25 @@ +{- | Multi line comments are parsed correctly. +-} +module TMulti () where + +{- ORMOLU_DISABLE -} + +-- this should work fine if previous multi comment is parsed correctly +-- >>> "a"++"b" +-- "ab" + + {- >>> 3+3 +6 + -} + +-- this should work fine if previous multi comment is parsed correctly +-- >>> "a"++"b" +-- "ab" + + {-| >>> "NOT IGNORED" +"NOT IGNORED" +-} + +-- this should work fine if previous multi comment is parsed correctly +-- >>> "a"++"b" +-- "ab" diff --git a/test/testdata/TNested.hs b/test/testdata/TNested.hs new file mode 100644 --- /dev/null +++ b/test/testdata/TNested.hs @@ -0,0 +1,13 @@ +module TNseted () where +{- +>>> 54 +{- +Nested +-} +-} + +{- +{- +>>> 42 +-} +-} diff --git a/test/testdata/TNested.hs.expected b/test/testdata/TNested.hs.expected new file mode 100644 --- /dev/null +++ b/test/testdata/TNested.hs.expected @@ -0,0 +1,15 @@ +module TNseted () where +{- +>>> 54 +54 +{- +Nested +-} +-} + +{- +{- +>>> 42 +42 +-} +-} diff --git a/test/testdata/TNoImplicitPrelude.hs b/test/testdata/TNoImplicitPrelude.hs new file mode 100644 --- /dev/null +++ b/test/testdata/TNoImplicitPrelude.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +module TNoImplicitPrelude where + +import Data.List (unwords) +import Data.String (String) + +-- >>> unwords example +example :: [String] +example = ["This","is","an","example","of","evaluation"] diff --git a/test/testdata/TNoImplicitPrelude.hs.expected b/test/testdata/TNoImplicitPrelude.hs.expected new file mode 100644 --- /dev/null +++ b/test/testdata/TNoImplicitPrelude.hs.expected @@ -0,0 +1,11 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +module TNoImplicitPrelude where + +import Data.List (unwords) +import Data.String (String) + +-- >>> unwords example +-- "This is an example of evaluation" +example :: [String] +example = ["This","is","an","example","of","evaluation"] diff --git a/test/testdata/TPlainComment.hs b/test/testdata/TPlainComment.hs new file mode 100644 --- /dev/null +++ b/test/testdata/TPlainComment.hs @@ -0,0 +1,25 @@ +{- | +Tests in plain comments in both single line or multi line format. +Tests are ignored if: + * do not start on the first column + * are in multi line comments that open and close on the same line +-} +module TPlain where + +{- ORMOLU_DISABLE -} + +-- Single line comment +-- >>> "a"++"b" + +{- Multi line comment + +>>> "b"++"c" +-} + +{- >>> 2+five + + ^-- This works, as it starts at the first column after the header. + + >>> IGNORED as it does not start on the first column +-} +five = 5 diff --git a/test/testdata/TPlainComment.hs.expected b/test/testdata/TPlainComment.hs.expected new file mode 100644 --- /dev/null +++ b/test/testdata/TPlainComment.hs.expected @@ -0,0 +1,28 @@ +{- | +Tests in plain comments in both single line or multi line format. +Tests are ignored if: + * do not start on the first column + * are in multi line comments that open and close on the same line +-} +module TPlain where + +{- ORMOLU_DISABLE -} + +-- Single line comment +-- >>> "a"++"b" +-- "ab" + +{- Multi line comment + +>>> "b"++"c" +"bc" +-} + +{- >>> 2+five +7 + + ^-- This works, as it starts at the first column after the header. + + >>> IGNORED as it does not start on the first column +-} +five = 5 diff --git a/test/testdata/TPrelude.hs b/test/testdata/TPrelude.hs new file mode 100644 --- /dev/null +++ b/test/testdata/TPrelude.hs @@ -0,0 +1,10 @@ +-- Prelude has no special treatment, it is imported as stated in the module. +module TPrelude where + +import Prelude hiding (foldr) + +-- >>> foldr (+) 10 [2,3,5] +foldr :: (a -> z -> z) -> z -> [a] -> z +foldr f z bs = + (foldl (\g a -> g . f a) id bs) z + diff --git a/test/testdata/TPrelude.hs.expected b/test/testdata/TPrelude.hs.expected new file mode 100644 --- /dev/null +++ b/test/testdata/TPrelude.hs.expected @@ -0,0 +1,11 @@ +-- Prelude has no special treatment, it is imported as stated in the module. +module TPrelude where + +import Prelude hiding (foldr) + +-- >>> foldr (+) 10 [2,3,5] +-- 20 +foldr :: (a -> z -> z) -> z -> [a] -> z +foldr f z bs = + (foldl (\g a -> g . f a) id bs) z + diff --git a/test/testdata/TProperty.hs b/test/testdata/TProperty.hs new file mode 100644 --- /dev/null +++ b/test/testdata/TProperty.hs @@ -0,0 +1,5 @@ +-- Support for property checking +module TProperty where + +-- prop> \(l::[Bool]) -> reverse (reverse l) == l + diff --git a/test/testdata/TProperty.hs.expected b/test/testdata/TProperty.hs.expected new file mode 100644 --- /dev/null +++ b/test/testdata/TProperty.hs.expected @@ -0,0 +1,6 @@ +-- Support for property checking +module TProperty where + +-- prop> \(l::[Bool]) -> reverse (reverse l) == l +-- +++ OK, passed 100 tests. + diff --git a/test/testdata/TSectionEval.hs b/test/testdata/TSectionEval.hs new file mode 100644 --- /dev/null +++ b/test/testdata/TSectionEval.hs @@ -0,0 +1,15 @@ +-- Tests in the same document section are executed together +module TSectionEval where + +{- +>>> 1+1 + +>>> 2+2 +-} + +{- +>>> 3+3 + +>>> 4+4 +-} + diff --git a/test/testdata/TSectionEval.hs.expected b/test/testdata/TSectionEval.hs.expected new file mode 100644 --- /dev/null +++ b/test/testdata/TSectionEval.hs.expected @@ -0,0 +1,17 @@ +-- Tests in the same document section are executed together +module TSectionEval where + +{- +>>> 1+1 +2 + +>>> 2+2 +4 +-} + +{- +>>> 3+3 + +>>> 4+4 +-} + diff --git a/test/testdata/TSetup.hs b/test/testdata/TSetup.hs new file mode 100644 --- /dev/null +++ b/test/testdata/TSetup.hs @@ -0,0 +1,10 @@ +-- The setup section is executed before any other test +module TSetup where + +-- $setup +-- >>> x=11 +-- >>> y=22 + +-- >>> x+y + +-- >>> x*y diff --git a/test/testdata/TSetup.hs.expected b/test/testdata/TSetup.hs.expected new file mode 100644 --- /dev/null +++ b/test/testdata/TSetup.hs.expected @@ -0,0 +1,12 @@ +-- The setup section is executed before any other test +module TSetup where + +-- $setup +-- >>> x=11 +-- >>> y=22 + +-- >>> x+y +-- 33 + +-- >>> x*y +-- 242 diff --git a/test/testdata/TUNPACK.hs b/test/testdata/TUNPACK.hs new file mode 100644 --- /dev/null +++ b/test/testdata/TUNPACK.hs @@ -0,0 +1,13 @@ +{- | Won't panic on UNPACKs -} +module TUNPACK (THStatus(..)) where + +type ByteString = String +type BSEndo = ByteString -> ByteString +type BSEndoList = [ByteString] -> [ByteString] + +data THStatus = THStatus + {-# UNPACK #-} !Int -- running total byte count + BSEndoList -- previously parsed lines + BSEndo -- bytestrings to be prepended + +-- >>> "Yay! UNPACK pragma didn't do bad things!" diff --git a/test/testdata/TUNPACK.hs.expected b/test/testdata/TUNPACK.hs.expected new file mode 100644 --- /dev/null +++ b/test/testdata/TUNPACK.hs.expected @@ -0,0 +1,14 @@ +{- | Won't panic on UNPACKs -} +module TUNPACK (THStatus(..)) where + +type ByteString = String +type BSEndo = ByteString -> ByteString +type BSEndoList = [ByteString] -> [ByteString] + +data THStatus = THStatus + {-# UNPACK #-} !Int -- running total byte count + BSEndoList -- previously parsed lines + BSEndo -- bytestrings to be prepended + +-- >>> "Yay! UNPACK pragma didn't do bad things!" +-- "Yay! UNPACK pragma didn't do bad things!" diff --git a/test/testdata/Util.hs b/test/testdata/Util.hs new file mode 100644 --- /dev/null +++ b/test/testdata/Util.hs @@ -0,0 +1,13 @@ +-- Used for testing local imports +module Util + ( tst + , a + , b + ) +where + +tst a b = a == b + +a = 'a' + +b = 'b' diff --git a/test/testdata/hie.yaml b/test/testdata/hie.yaml new file mode 100644 --- /dev/null +++ b/test/testdata/hie.yaml @@ -0,0 +1,4 @@ +cradle: + cabal: + - path: "././" + component: "lib:test" diff --git a/test/testdata/test.cabal b/test/testdata/test.cabal new file mode 100644 --- /dev/null +++ b/test/testdata/test.cabal @@ -0,0 +1,63 @@ +name: test +version: 0.1.0.0 +-- synopsis: +-- description: +license: BSD3 +author: Author name here +maintainer: example@example.com +copyright: 2017 Author name here +category: Web +build-type: Simple +cabal-version: >=1.10 + +library + exposed-modules: + T1 + T2 + T3 + T4 + T5 + T6 + T7 + T8 + T9 + T10 + T11 + T12 + T13 + T14 + T15 + T16 + T17 + T18 + T19 + T20 + T21 + T22 + T23 + T24 + T25 + T26 + T27 + TEndingMulti + TMulti + TPlainComment + THaddock + TCompare + TLocalImport + TLocalImportInTest + TFlags + TLanguageOptionsTupleSections + TIO + TProperty + TPrelude + TCPP + TLHS + TSetup + Util + TNested + + build-depends: base >= 4.7 && < 5, QuickCheck + default-language: Haskell2010 + ghc-options: -Wall -fwarn-unused-imports +