diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,317 +1,3 @@ # Changelog for ghc-lib-parser-ex -## 0.20221201 released -- Update to `ghc-lib-parser-0.20221201` - -## 0.20221101 released -- Update to `ghc-lib-parser-0.20221101` - -## 0.20221001 released -- Update to `ghc-lib-parser-0.20221001` - -## 0.20220901 released -- Update to `ghc-lib-parser-0.20220901` - -## 9.4.0.0 released -- Update to `ghc-lib-parser-9.4.1.20220807` - -## 0.20220801 released -- Update to `ghc-lib-parser-0.20220801` - -## 9.2.1.1 released -- Update to `ghc-lib-parser-9.2.4.20220527` - -## 0.20220701 released -- Update to `ghc-lib-parser-0.20220701` - -## 9.2.1.0 released -- The Cabal flag `auto` now defaults to `False`: - - When `auto` has the value `False`: - - `ghc-lib-parser-ex` depends on `ghc-lib-parser` - - When `auto` has the value `True`: - - When the build compiler is >=9.2.2 && <9.3.0 - - `ghc-lib-parser-ex` depends on the compiler libs - - Otherwise, `ghc-lib-parser-ex` depends on `ghc-lib-parser` -- Deprecated modues removed: - - `Language.Haskell.GhclibParserEx.Config` - - `Language.Haskell.GhclibParserEx.Parse` - - `Language.Haskell.GhclibParserEx.Outputable` - -## 0.20220601 released -- Update to `ghc-lib-parser-0.20220601` -- `fakeLlvmConfig` removed for `GHCLIB_API_HEAD` - -## 9.2.0.4 released -- Update to `ghc-lib-parser-9.2.3.20220527` -- Add support for ghc-9.4 series: `GHCLIB_API_904` - -## 0.20220501 released -- Update to `ghc-lib-parser-0.20220501` - -## 0.20220401 released -- Update to `ghc-lib-parser-0.20220401` - -## 9.2.0.3 released -- Fix ghc bounds in auto mode to use ghc-lib not ghc if build compiler ghc-9.2.1 (see [issue](https://github.com/ndmitchell/hlint/issues/1314)) - -## 9.2.0.2 released -- Update to `ghc-lib-parser-9.2.2.20220307` - -## 0.20220301 released -- Update to `ghc-lib-parser-0.20220301` - -## 8.10.0.24 released -- Update to `ghc-lib-parser-8.10.7.20220219` - -## 0.20220201 released -- Update to `ghc-lib-parser-0.20220201` - -## 0.20220103 released -- New function `isOverLabel` -- Update to `ghc-lib-parser-0.20220103` - -## 9.0.0.6 released 2021-12-26 -- Add back `isQuasiQuote` for backwards compatibility - -## 9.0.0.5 released 2021-12-25 -- Bugfix to `isFieldPunUpdate` -- New module `Language.Haskell.GHC.Hs.Type.hs` to replace `Language.Haskell.GHC.Hs.Types.hs` (which remains for now but deprecated and will be removed in a future release) - - New function `isKindTyApp` -- Rename `isQuasiQuote` to `isQuasiQuoteExpr` -- Add new function `isQuasiQuoteSplice` -- Update to `ghc-lib-parser-9.0.2.20211226` - -## 9.2.0.1 released 2021-11-01 -- Update to `ghc-lib-parser-9.2.1.20211101` - -## 0.20211101 released 2021-11-01 -- Update to `ghc-lib-parser-0.20211101` - -## 9.2.0.0 released 2021-10-30 -- Update to `ghc-lib-parser-9.2.1.20211030` - -## 0.20211001 released 2021-10-01 -- Add `isSplicePat` to `Language.Haskell.GhclibParserEx.GHC.Hs.Pat` -- Use `genericPlatform` on `GHCLIB_API_HEAD` in `GhclibParserEx.GHC.Settings.Config.hs` -- Update to `ghc-lib-parser-0.20211001` - -## 0.20210901 released 2021-09-01 -- Update to `ghc-lib-parser-0.20210901` - -## 8.10.0.23 released 2021-08-28 -- Update to `ghc-lib-parser-8.10.7.20210828` - -## 8.10.0.22 released 2021-08-14 -- Update to `ghc-lib-parser-0.20210814` -- Added to `GhclibParserEx.GHC.Hs.Expr`: - - `isMonadComp` - - `isListComp` - -## 0.20210701 released 2021-07-01 -- Update to `ghc-lib-0.20210701` - -## 8.10.0.21 released 2021-06-07 -- Bugfix cabal files - -## 8.10.0.20 released 2021-06-06 -- Update to `ghc-lib-8.10.5.20210606` - -## 0.20210601 released 2021-06-01 -- Update to `ghc-lib-parser-0.20210601` -- Update types in `GHC.Types.Name.Reader` for ghc-9.2.1, `Located` becomes `LocatedN` - -## 0.20210501 released 2021-05-01 -- Update to `ghc-lib-0.20210501` - -## 0.20210331 released 2021-02-31 -- Update to `ghc-lib-0.20210331` -- Update to `ghc-lib-parser-9.0.1.20210324` - -## 9.0.0.4 released 2021-03-11 -- Bugfix for `GHC.Hs.Dump` - -## 0.20210228 released 2021-02-28 -- Update to `ghc-lib-0.20210228` - -## 9.0.0.3 released 2021-02-08 -- Cabal bugfix - -## 9.0.0.2 released 2021-02-08 -- Cabal bugfix - -## 8.10.0.19 released 2021-02-08 -- Cabal bugfix - -## 8.10.0.18 released 2021-02-06 -- Update to ghc-8.10.4. - -## 9.0.0.1 released 2021-02-05 -- Upgrade Cabal defaults flag to 9.0.1 - -## 9.0.0.0 released 2021-02-05 -- Update to ghc-9.0.1 - -## 0.20210201 released 2021-02-01 -- Update to `ghc-lib-0.20210201` - -## 0.20210101 released 2021-01-01 -- Update to `ghc-lib-0.20210101` - -## 8.10.0.17 released 2020-12-20 -- Update to ghc-8.10.3. - -## 0.20201101 released 2020-11-01 -- Update to `ghc-lib-0.20201101` - -## 0.20201001 released 2020-10-01 -- Update to `ghc-lib-0.20201001` -- `GHCLIB_API_811` -> `GHCLIB_API_HEAD` -- Add support for `GHCLIB_API_900` - -## 0.20200901 released 2020-09-01 -- Update to `ghc-lib-0.20200901` - -## 8.10.0.16 released 2020-08-08 -- Update to ghc-8.10.2. - -## 0.20200801 released 2020-08-01 -- Update to `ghc-lib-0.20200801` - -## 8.8.6.1 released 2020-07-16 - -## 0.20200704 released 2020-07-04 -- New function `isImportQualifiedPost` - -## 8.10.0.15 released 2020-07-04 -- New function `isImportQualifiedPost` - -## 8.10.0.14 released 2020-06-10 -- New function `isSymbolRdrName` -- New module - - `Language.Haskell.GhclibParserEx.GHC.Settings.Config` to replace `Language.Haskell.GhclibParserEx.Config` (which remains for now but deprecated and will be removed in a future release) - -## 0.20200601 released 2020-06-01 - -## 8.10.0.13 released 2020-05-31 -- Sync `extra` with HLint - -## 8.10.0.12 released 2020-05-31 -- New module `Language.Haskell.GhclibParserEx.GHC.Hs` - -## 8.10.0.11 released 2020-05-18 -- Upgrade to `ghc-lib-parser-8.10.1.20200523` - -## 8.10.0.10 released 2020-05-18 -- Upgrade to `ghc-lib-parser-8.10.1.20200518` - -## 8.10.0.9 released 2020-05-16 -- New modules - - `Language.Haskell.GhclibParserEx.GHC.Hs.Binds` - - `Language.Haskell.GhclibParserEx.GHC.Hs.ImpExp` - -## 8.10.0.8 released 2020-05-14 -- New module `Language.Haskell.GhclibParserEx.GHC.Types.Name.Reader` - -## 8.10.0.7 released 2020-05-13 -- New function `fixitiesFromModule` - -## 8.10.0.6 released 2020-05-05 -- Bugfix in `parsePragmasIntoDynFlags` that meant that default enabled/disabled extensions subsequently disabled/enabled via pragma weren't getting disabled/enabled - -## 8.10.0.5 released 2020-05-02 -- New modules - - `Language.Haskell.GhclibParserEx.GHC.Parser`, `Language.Haskell.GhcLibParserEx.GHC.Utils.Outputable` to replace `Language.Haskell.GhclibParserEx.Parse` and `Language.Haskell.GhclibParserEx.Outputable` (which remain for now but deprecated and will be removed in a future release) - -## 0.20200501 released 2020-05-01 - -## 8.10.0.4 released 2020-04-04 -- Add expression predicates `isWholeFrac`, `isFieldPunUpdate`, `isStrictMatch`, `isMultiIf`, `isProc`, `isTransStmt`; -- Add pattern predicate `isPFieldPun`. - -## 8.10.0.3 released 2020-04-03 -- `strToPat` now returns an `LPat GhcPs` -- `parseExpression` now returns an `ParseResult (LHsExpr GhcPs)` (>= ghc-8.10) - -## 0.20200401 released 2020-04-01 - -## 8.10.0.2 released 2020-03-30 -- Rework cabal flags; allow full configurability with a good default: - - Have two flags `auto` and `no-ghc-lib`. Default behavior exactly as `hlint` linking `ghc-lib-parser-8.10.*` if not on `ghc-8.10.*` and `ghc-8.10.*` otherwise. - -## 8.10.0.1 released 2020-03-28 -- Unless the Cabal flag `ghc-lib` is `true` link native ghc-libs (without regard for the compiler version) -- Change the signature of `hasPFieldsDotDot` - - This has no impact on 8.8 parse trees but matters when it comes to >= 8.10 -- Change the signature of `isPFieldWildcard` - - This has no impact on 8.8 parse trees but matters when it comes to >= 8.10 - -## 8.10.0.0 released 2020-03-24 -- First release of the ghc-8.10 series - -## 8.8.6.0 released 2020-03-22 -- `Language.Haskell.GhclibParserEx.DynFlags` is now `Language.Haskell.GhclibParserEx.GHC.Driver.Session` - -## 8.8.5.8 released 2020-03-17 -- New module `Language.Haskell.GhclibParserEx.GHC.Driver.Flags` - - Export `Bounded` instance for `Language` - (https://github.com/shayne-fletcher/ghc-lib-parser-ex/issues/30) - -## 8.8.5.7 released 2020-03-16 -- From `Language.Haskell.GhclibParserEx.Fixity`: - - Supply missing fixities (https://github.com/ndmitchell/hlint/issues/913) -- In `Language.Haskell.GhclibParserEx.DynFlags`: - - Give `Extension` an `Ord` instance - -## 8.8.5.6 released 2020-03-13 -- From `Language.Haskell.GhclibParserEx.Fixity`: - - Expose `infixr_`, `infixl_`, `infix_` and `fixity` - -## 8.8.5.5 released 2020-03-12 -- Remove from `Language.Haskell.GhclibParserEx.Fixity`: - - `preludeFixities` - - `baseFixities` - -## 8.8.5.4 released 2020-03-11 -- Expose from `Language.Haskell.GhclibParserEx.Fixity`: - - `preludeFixities` - - `baseFixities` - - `lensFixities` - - `otherFixities` - -## 0.20200301 released 2020-03-01 - -## 8.8.5.3 released 2020-02-25 -- New modules: - - `Language.Haskell.GhclibParserEx.Pat` - - `Language.Haskell.GhclibParserEx.Types` - - `Language.Haskell.GhclibParserEx.Decls` - -## 8.8.5.2 released 2020-02-16 -- New `DynFlags` functions `readExtension`, `extensionImplications`. - -## 8.8.5.1 released 2020-02-09 -- Expression predicate tests. - -## 8.8.5.0 released 2020-02-07 -- Expose `impliedGFlags` and friends from `DynFlags` (https://github.com/shayne-fletcher/ghc-lib-parser-ex/issues/19). - -## 8.8.4.0 released 2020-02-01 -- New modules: - - `Language.Haskell.GhclibparserEx.GHC.Hs.Expr` -- Moved modules: - - `Language.Haskell.GhclibparserEx.HsExtendInstances` -> - `Language.Haskell.GhclibparserEx.GHC.Hs.ExtendInstances`; - -## 0.20200201.1.0 released 2020-02-01 -- New modules: - - `Language.Haskell.GhclibparserEx.HsExtendInstances`. - -## 8.8.3.0 released 2020-01-25 -- Change in versioning scheme; -- New modules: - - `Language.Haskell.GhclibParserEx.Config` - - `Language.Haskell.GhclibParserEx.DynFlags` -- `parsePragmasIntoDynFlags` signature change. - -## 8.8.1.20191204, 8.8.2, 0.20200102 released 2020-01-18 -- First releases +## 8.8.1.20191204, released 2020-01-18 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,34 +1,27 @@ -# ghc-lib-parser-ex [![License BSD3](https://img.shields.io/badge/license-BSD3-brightgreen.svg)](http://opensource.org/licenses/BSD-3-Clause) [![Hackage version](https://img.shields.io/hackage/v/ghc-lib-parser-ex.svg?label=Hackage)](https://hackage.haskell.org/package/ghc-lib-parser-ex) [![Stackage version](https://www.stackage.org/package/ghc-lib-parser-ex/badge/nightly?label=Stackage)](https://www.stackage.org/package/ghc-lib-parser-ex) [![Build Status](https://shayne-fletcher.visualstudio.com/ghc-lib-parser-ex/_apis/build/status/shayne-fletcher.ghc-lib-parser-ex?branchName=master)](https://shayne-fletcher.visualstudio.com/ghc-lib-parser-ex/_build/latest?definitionId=1&branchName=master) -Copyright © 2020-2022 Shayne Fletcher. All rights reserved. +# ghc-lib-parser-ex [![Build Status](https://shayne-fletcher.visualstudio.com/ghc-lib-parser-ex/_apis/build/status/shayne-fletcher.ghc-lib-parser-ex?branchName=master)](https://shayne-fletcher.visualstudio.com/ghc-lib-parser-ex/_build/latest?definitionId=1&branchName=master) +Copyright © 2020, Shayne Fletcher. All rights reserved. SPDX-License-Identifier: BSD-3-Clause The `ghc-lib-parser-ex` package contains GHC API parse tree utilities. It works with or without [`ghc-lib-parser`](https://github.com/digital-asset/ghc-lib). ## Using `ghc-lib-parser-ex` -Package `ghc-lib-parser-ex` is on [Hackage](https://hackage.haskell.org/package/ghc-lib-parser-ex) e.g. `cabal install ghc-lib-parser-ex`. Like `ghc-lib-parser`, there are two release streams within the `ghc-lib-parser-ex` name. - -### Versioning policy - -Package `ghc-lib-parser-ex` does **not** conform to the [Haskell Package Versioning Policy](https://pvp.haskell.org/). Version numbers are of the form α.β.γ.δ where α.β corresponds to a GHC series and γ.δ are the major and minor parts of the `ghc-lib-ex-parser` package release. Examples: -* Version 8.10.1.3 is compatible with any `ghc-lib-parser-8.10.*` (or `ghc-8.10.*`) package; -* Version 0.20190204.2.0 is compatible with [`ghc-lib-parser-0.20190204`](http://hackage.haskell.org/package/ghc-lib-0.20190204). +The package `ghc-lib-parser-ex` is available on [Hackage](https://hackage.haskell.org/) e.g. `cabal install ghc-lib-parser-ex`. There are two release streams within the `ghc-lib-parser-ex` name (tracking released `ghc-lib-parser` versions exactly): -The major part γ of the release number indicates an interface breaking change from the previous release. The minor part δ indicates a non-interface breaking change from the previous release. +* Version 8.10.1 will be the `ghc-lib-parser-ex` for use against `ghc-lib-parser-8.10.1`(or the released GHC 8.10.1); +* Version 0.20190204 is for use against [`ghc-lib-parser-0.20190204`](http://hackage.haskell.org/package/ghc-lib-0.20190204). -## Building `ghc-lib-parser-ex` +### Building `ghc-lib-parser-ex` -Produce and test `ghc-lib-parser-ex` package distributions by executing the CI script: +You can build with `stack build` and test with `stack test`. You can also produce `ghc-lib-parser-ex` package distributions by executing the CI script (which incidentally builds everything and runs the tests). ```bash # Setup git clone git@github.com:shayne-fletcher/ghc-lib-parser-ex.git cd ghc-lib-parser-ex stack runhaskell --package extra --package optparse-applicative CI.hs ``` -Run `stack runhaskell --package extra --package optparse-applicative CI.hs -- --help` for more options. - -To run [`hlint`](https://github.com/ndmitchell/hlint) on this repository, `hlint --cpp-include cbits --cpp-define GHCLIB_API_XXX .` (where `XXX` at this time is one of `808`, `810`, `900`, `902`, `904` or `HEAD`). +Run `stack runhaskell --package extra --package optparse-applicative CI.hs -- --help` for more configurability options. -## Releasing `ghc-lib-parser-ex` (notes for maintainers) +## Releasing `ghc-lib` (notes for maintainers) -Update the [changelog](./ChangeLog.md), `git tag && git push origin ` then build via the [above instructions](#building-ghc-lib-parser-ex) and upload the resulting `.tar.gz` files to [Hackage](https://hackage.haskell.org/upload). +Build `ghc-lib-parser-ex` using the [above instructions](#building-ghc-lib-parser-ex) and upload the resulting `.tar.gz` files to [Hackage](https://hackage.haskell.org/upload). diff --git a/cbits/ghclib_api.h b/cbits/ghclib_api.h --- a/cbits/ghclib_api.h +++ b/cbits/ghclib_api.h @@ -1,49 +1,33 @@ /* -Copyright (c) 2020, 2021 Shayne Fletcher. All rights reserved. -SPDX-License-Identifier: BSD-3-Clause. +Copyright (c) 2020, Shayne Fletcher. All rights +reserved. SPDX-License-Identifier: BSD-3-Clause. */ #if !defined(GHCLIB_API_H) # define GHCLIB_API_H -# if !(defined (GHCLIB_API_HEAD) \ - || defined (GHCLIB_API_904) \ - || defined (GHCLIB_API_902) \ - || defined (GHCLIB_API_900) \ - || defined (GHCLIB_API_810) \ - || defined (GHCLIB_API_808)) +# if !defined(GHCLIB_API_811) && !defined(GHCLIBAPI_810) && !defined(GHCLIB_API_808) # if defined(MIN_VERSION_ghc_lib_parser) -# if !MIN_VERSION_ghc_lib_parser( 1, 0, 0) -# define GHCLIB_API_HEAD -# elif MIN_VERSION_ghc_lib_parser(9, 4, 0) -# define GHCLIB_API_904 -# elif MIN_VERSION_ghc_lib_parser(9, 2, 0) -# define GHCLIB_API_902 -# elif MIN_VERSION_ghc_lib_parser(9, 0, 0) -# define GHCLIB_API_900 -# elif MIN_VERSION_ghc_lib_parser(8, 10, 0) -# define GHCLIB_API_810 -# elif MIN_VERSION_ghc_lib_parser(8, 8, 0) +# if !MIN_VERSION_ghc_lib_parser(1, 0, 0) +# define GHCLIB_API_811 +# elif MIN_VERSION_ghc_lib_parser(8, 10, 0) +# define GHCLIBAPI_810 +# elif MIN_VERSION_ghc_lib_parser(8, 8, 0) # define GHCLIB_API_808 # else # error Unsupported GHC API version # endif # else -# if __GLASGOW_HASKELL__ == 905 -# define GHCLIB_API_HEAD -# elif __GLASGOW_HASKELL__ == 904 -# define GHCLIB_API_904 -# elif __GLASGOW_HASKELL__ == 902 -# define GHCLIB_API_902 -# elif __GLASGOW_HASKELL__ == 900 -# define GHCLIB_API_900 +# if __GLASGOW_HASKELL__ == 811 +# define GHCLIB_API_811 # elif __GLASGOW_HASKELL__ == 810 # define GHCLIB_API_810 -# elif __GLASGOW_HASKELL__ == 808 +# elif __GLASGOW_HASKELL__ == 808 # define GHCLIB_API_808 # else # error Unsupported GHC API version # endif # endif # endif + #endif diff --git a/ghc-lib-parser-ex.cabal b/ghc-lib-parser-ex.cabal --- a/ghc-lib-parser-ex.cabal +++ b/ghc-lib-parser-ex.cabal @@ -1,12 +1,12 @@ -cabal-version: 1.18 +cabal-version: >= 1.18 name: ghc-lib-parser-ex -version: 0.20221201 +version: 8.8.1.20191204 description: Please see the README on GitHub at homepage: https://github.com/shayne-fletcher/ghc-lib-parser-ex#readme bug-reports: https://github.com/shayne-fletcher/ghc-lib-parser-ex/issues author: Shayne Fletcher maintainer: shayne@shaynefletcher.org -copyright: Copyright © 2020-2022 Shayne Fletcher. All rights reserved. +copyright: Copyright © 2020, Shayne Fletcher. All rights reserved. license: BSD3 license-file: LICENSE category: Development @@ -15,41 +15,24 @@ extra-source-files: README.md ChangeLog.md - cbits/ghclib_api.h +extra-source-files: + cbits/ghclib_api.h source-repository head type: git location: https://github.com/shayne-fletcher/ghc-lib-parser-ex -flag auto - default: False - manual: True - description: Use default configuration - -flag no-ghc-lib +flag ghc-lib default: False manual: True - description: Force dependency on native ghc-libs + description: Force dependency on ghc-lib-parser even if GHC API in the ghc package is supported library exposed-modules: + Language.Haskell.GhclibParserEx.Parse + Language.Haskell.GhclibParserEx.Outputable Language.Haskell.GhclibParserEx.Dump Language.Haskell.GhclibParserEx.Fixity - Language.Haskell.GhclibParserEx.GHC.Settings.Config - Language.Haskell.GhclibParserEx.GHC.Driver.Flags - Language.Haskell.GhclibParserEx.GHC.Driver.Session - Language.Haskell.GhclibParserEx.GHC.Hs - Language.Haskell.GhclibParserEx.GHC.Hs.Expr - Language.Haskell.GhclibParserEx.GHC.Hs.Pat - Language.Haskell.GhclibParserEx.GHC.Hs.Type - Language.Haskell.GhclibParserEx.GHC.Hs.Types - Language.Haskell.GhclibParserEx.GHC.Hs.Decls - Language.Haskell.GhclibParserEx.GHC.Hs.Binds - Language.Haskell.GhclibParserEx.GHC.Hs.ImpExp - Language.Haskell.GhclibParserEx.GHC.Hs.ExtendInstances - Language.Haskell.GhclibParserEx.GHC.Parser - Language.Haskell.GhclibParserEx.GHC.Types.Name.Reader - Language.Haskell.GhclibParserEx.GHC.Utils.Outputable other-modules: Paths_ghc_lib_parser_ex hs-source-dirs: @@ -57,13 +40,14 @@ build-depends: base >=4.7 && <5, uniplate >= 1.5, - bytestring >= 0.10.8.2, - containers >= 0.5.8.1 - build-depends: - ghc-lib-parser == 0.20221201 - -- pseduo use of flags to suppress cabal check warnings - if flag(auto) - if flag(no-ghc-lib) + bytestring >= 0.10.8.2 + if !flag(ghc-lib) && impl(ghc >= 8.8.0) && impl(ghc < 8.9.0) + build-depends: + ghc == 8.8.*, + ghc-boot-th + else + build-depends: + ghc-lib-parser == 8.8.1.20191204 include-dirs: cbits install-includes: @@ -83,16 +67,17 @@ ghc-options: -threaded -rtsopts -with-rtsopts=-N build-depends: base >=4.7 && <5 - , tasty >= 1.2 + , tasty >= 1.2.3 , tasty-hunit >= 0.10.0 , directory >= 1.3.3 , filepath >= 1.4.2 , extra >=1.6 - , uniplate >= 1.6.12 , ghc-lib-parser-ex - build-depends: - ghc-lib-parser == 0.20221201 - -- pseduo use of flags to suppress cabal check warnings - if flag(auto) - if flag(no-ghc-lib) + if !flag(ghc-lib) && impl(ghc >= 8.8.0) && impl(ghc < 8.9.0) + build-depends: + ghc == 8.8.*, + ghc-boot-th + else + build-depends: + ghc-lib-parser == 8.8.1.20191204 default-language: Haskell2010 diff --git a/src/Language/Haskell/GhclibParserEx/Dump.hs b/src/Language/Haskell/GhclibParserEx/Dump.hs --- a/src/Language/Haskell/GhclibParserEx/Dump.hs +++ b/src/Language/Haskell/GhclibParserEx/Dump.hs @@ -1,6 +1,19 @@ -- Copyright (c) 2020, Shayne Fletcher. All rights reserved. -- SPDX-License-Identifier: BSD-3-Clause. {- +Currently 'showAstData' is only available in ghc-lib. I intend to +move it to ghc-lib-parser. Then, we'll be able to get at it with +something like, + + #if defined (GHCLIB_API_811) || defined (GHCLIB_API_810) + import GHC.Hs.Dump + #else + import HsDumpAst + #endif + +The implementation is reproduced here until that time. +-} +{- (c) The University of Glasgow 2006 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -} @@ -12,27 +25,9 @@ #include "ghclib_api.h" module Language.Haskell.GhclibParserEx.Dump( showAstData - , BlankSrcSpan(..) -#if defined(GHCLIB_API_HEAD) || defined (GHCLIB_API_904) || defined(GHCLIB_API_902) - , BlankEpAnnotations(..) -#endif + , BlankSrcSpan(..), ) where -#if !defined(MIN_VERSION_ghc_lib_parser) --- Using native ghc. -# if defined (GHCLIB_API_HEAD) || defined (GHCLIB_API_904) || defined(GHCLIB_API_902) || defined(GHCLIB_API_900) || defined (GHCLIB_API_810) -import GHC.Hs.Dump -# else -import HsDumpAst -# endif -#else --- Using ghc-lib-parser. Recent versions will include --- GHC.Hs.Dump (it got moved in from ghc-lib on 2020-02-05). -# if defined (GHCLIB_API_HEAD) || defined (GHCLIB_API_904) || defined(GHCLIB_API_902) || defined (GHCLIB_API_900) || defined (GHCLIB_API_810) -import GHC.Hs.Dump -# else --- For simplicity, just assume it's missing from 8.8 ghc-lib-parser --- builds and reproduce the implementation. import Prelude as X hiding ((<>)) import Data.Data hiding (Fixity) @@ -43,7 +38,7 @@ import Name import DataCon import SrcLoc -#if defined (GHCLIB_API_HEAD) || defined (GHCLIB_API_904) || defined(GHCLIB_API_902) || defined (GHCLIB_API_900) || defined (GHCLIB_API_810) +#if defined (GHCLIB_API_811) || defined (GHCLIB_API_810) import GHC.Hs #else import HsSyn @@ -238,5 +233,3 @@ -> (forall d1 d2. (Data d1, Data d2) => c (t d1 d2)) -> c a ext2 def ext = maybe def id (dataCast2 ext) -# endif -#endif diff --git a/src/Language/Haskell/GhclibParserEx/Fixity.hs b/src/Language/Haskell/GhclibParserEx/Fixity.hs --- a/src/Language/Haskell/GhclibParserEx/Fixity.hs +++ b/src/Language/Haskell/GhclibParserEx/Fixity.hs @@ -9,42 +9,22 @@ {-# LANGUAGE TupleSections #-} #include "ghclib_api.h" -module Language.Haskell.GhclibParserEx.Fixity( - applyFixities - , fixitiesFromModule - , preludeFixities, baseFixities - , infixr_, infixl_, infix_, fixity - ) where +module Language.Haskell.GhclibParserEx.Fixity(applyFixities) where -#if defined (GHCLIB_API_HEAD) || defined (GHCLIB_API_904) || defined(GHCLIB_API_902) || defined (GHCLIB_API_900) -import GHC.Hs -#if defined (GHCLIB_API_HEAD) || defined (GHCLIB_API_904) || defined(GHCLIB_API_902) -import GHC.Types.Fixity -import GHC.Types.SourceText -#else -import GHC.Types.Basic -#endif -import GHC.Types.Name.Reader -import GHC.Types.Name -import GHC.Types.SrcLoc -#elif defined (GHCLIB_API_810) -import GHC.Hs import BasicTypes -import RdrName -import OccName -import SrcLoc +#if defined (GHCLIB_API_811) || defined (GHCLIB_API_810) +import GHC.Hs #else import HsSyn -import BasicTypes +#endif import RdrName import OccName import SrcLoc -#endif import Data.Maybe import Data.Data hiding (Fixity) import Data.Generics.Uniplate.Data -#if defined (GHCLIB_API_900) || defined (GHCLIB_API_810) +#if defined (GHCLIB_API_811) || defined (GHCLIB_API_810) noExt :: NoExtField noExt = noExtField #endif @@ -64,10 +44,7 @@ -- LPat and Pat have gone through a lot of churn. See -- https://gitlab.haskell.org/ghc/ghc/merge_requests/1925 for details. patFix :: [(String, Fixity)] -> LPat GhcPs -> LPat GhcPs -#if defined (GHCLIB_API_HEAD) || defined (GHCLIB_API_904) || defined(GHCLIB_API_902) || defined (GHCLIB_API_900) -patFix fixities (L loc (ConPat _ op (InfixCon pat1 pat2))) = - L loc (mkConOpPat (getFixities fixities) op (findFixity' (getFixities fixities) op) pat1 pat2) -#elif defined (GHCLIB_API_810) +#if defined (GHCLIB_API_811) || defined (GHCLIB_API_810) patFix fixities (L loc (ConPatIn op (InfixCon pat1 pat2))) = L loc (mkConOpPat (getFixities fixities) op (findFixity' (getFixities fixities) op) pat1 pat2) #else @@ -78,133 +55,68 @@ mkConOpPat :: [(String, Fixity)] -#if defined (GHCLIB_API_HEAD) || defined (GHCLIB_API_904) || defined(GHCLIB_API_902) - -> LocatedN RdrName -#else - -> Located RdrName -#endif - -> Fixity + -> Located RdrName -> Fixity -> LPat GhcPs -> LPat GhcPs -> Pat GhcPs -#if defined (GHCLIB_API_HEAD) || defined (GHCLIB_API_904) || defined(GHCLIB_API_902) || defined (GHCLIB_API_900) -mkConOpPat fs op2 fix2 p1@(L loc (ConPat _ op1 (InfixCon p11 p12))) p2 -#elif defined (GHCLIB_API_810) +#if defined (GHCLIB_API_811) || defined (GHCLIB_API_810) mkConOpPat fs op2 fix2 p1@(L loc (ConPatIn op1 (InfixCon p11 p12))) p2 #else mkConOpPat fs op2 fix2 p1@(dL->L loc (ConPatIn op1 (InfixCon p11 p12))) p2 #endif -#if defined (GHCLIB_API_HEAD) || defined (GHCLIB_API_904) || defined(GHCLIB_API_902) - | nofix_error = ConPat noAnn op2 (InfixCon p1 p2) -#elif defined (GHCLIB_API_900) - | nofix_error = ConPat noExtField op2 (InfixCon p1 p2) -#else | nofix_error = ConPatIn op2 (InfixCon p1 p2) -#endif -#if defined (GHCLIB_API_HEAD) || defined (GHCLIB_API_904) || defined(GHCLIB_API_902) - | associate_right = ConPat noAnn op1 (InfixCon p11 (L loc (mkConOpPat fs op2 fix2 p12 p2))) -#elif defined (GHCLIB_API_900) - | associate_right = ConPat noExtField op1 (InfixCon p11 (L loc (mkConOpPat fs op2 fix2 p12 p2))) -#elif defined (GHCLIB_API_810) +#if defined (GHCLIB_API_811) || defined (GHCLIB_API_810) | associate_right = ConPatIn op1 (InfixCon p11 (L loc (mkConOpPat fs op2 fix2 p12 p2))) #else - | associate_right = ConPatIn op1 (InfixCon p11 (cL loc (mkConOpPat fs op2 fix2 p12 p2))) + | associate_right = let new_p = mkConOpPat fs op2 fix2 p12 p2 in ConPatIn op1 (InfixCon p11 (cL loc new_p)) #endif -#if defined (GHCLIB_API_HEAD) || defined (GHCLIB_API_904) || defined(GHCLIB_API_902) - | otherwise = ConPat noAnn op2 (InfixCon p1 p2) -#elif defined (GHCLIB_API_900) - | otherwise = ConPat noExtField op2 (InfixCon p1 p2) -#else | otherwise = ConPatIn op2 (InfixCon p1 p2) -#endif where fix1 = findFixity' fs op1 (nofix_error, associate_right) = compareFixity fix1 fix2 -#if defined (GHCLIB_API_HEAD) || defined (GHCLIB_API_904) || defined(GHCLIB_API_902) -mkConOpPat _ op _ p1 p2 = ConPat noAnn op (InfixCon p1 p2) -#elif defined (GHCLIB_API_900) -mkConOpPat _ op _ p1 p2 = ConPat noExtField op (InfixCon p1 p2) -#else mkConOpPat _ op _ p1 p2 = ConPatIn op (InfixCon p1 p2) -#endif mkOpApp :: - [(String, Fixity)] -#if defined(GHCLIB_API_HEAD) || defined (GHCLIB_API_904) || defined(GHCLIB_API_902) - -> SrcSpanAnnA -#else - -> SrcSpan -#endif - -> LHsExpr GhcPs -- Left operand; already rearrange. - -> LHsExpr GhcPs -> Fixity -- Operator and fixity. - -> LHsExpr GhcPs -- Right operand (not an OpApp, but might be a NegApp). - -> LHsExpr GhcPs + [(String, Fixity)] + -> SrcSpan + -> LHsExpr GhcPs -- Left operand; already rearrange. + -> LHsExpr GhcPs -> Fixity -- Operator and fixity. + -> LHsExpr GhcPs -- Right operand (not an OpApp, but might be a NegApp). + -> LHsExpr GhcPs -- (e11 `op1` e12) `op2` e2 mkOpApp fs loc e1@(L _ (OpApp x1 e11 op1 e12)) op2 fix2 e2 -#if defined (GHCLIB_API_HEAD) || defined (GHCLIB_API_904) || defined(GHCLIB_API_902) - | nofix_error = L loc (OpApp noAnn e1 op2 e2) -#else | nofix_error = L loc (OpApp noExt e1 op2 e2) -#endif | associate_right = L loc (OpApp x1 e11 op1 (mkOpApp fs loc' e12 op2 fix2 e2 )) where -#if defined (GHCLIB_API_HEAD) || defined (GHCLIB_API_904) || defined(GHCLIB_API_902) - loc'= combineLocsA e12 e2 -#else loc'= combineLocs e12 e2 -#endif fix1 = findFixity fs op1 (nofix_error, associate_right) = compareFixity fix1 fix2 -- (- neg_arg) `op` e2 mkOpApp fs loc e1@(L _ (NegApp _ neg_arg neg_name)) op2 fix2 e2 -#if defined(GHCLIB_API_HEAD) || defined (GHCLIB_API_904) || defined(GHCLIB_API_902) - | nofix_error = L loc (OpApp noAnn e1 op2 e2) -#else | nofix_error = L loc (OpApp noExt e1 op2 e2) -#endif -#if defined(GHCLIB_API_HEAD) || defined (GHCLIB_API_904) || defined(GHCLIB_API_902) - | associate_right = L loc (NegApp noAnn (mkOpApp fs loc' neg_arg op2 fix2 e2) neg_name) -#else | associate_right = L loc (NegApp noExt (mkOpApp fs loc' neg_arg op2 fix2 e2) neg_name) -#endif where -#if defined (GHCLIB_API_HEAD) || defined (GHCLIB_API_904) || defined(GHCLIB_API_902) - loc' = combineLocsA neg_arg e2 -#else loc' = combineLocs neg_arg e2 -#endif (nofix_error, associate_right) = compareFixity negateFixity fix2 -- e1 `op` - neg_arg mkOpApp _ loc e1 op1 fix1 e2@(L _ NegApp {}) -- NegApp can occur on the right. -#if defined(GHCLIB_API_HEAD) || defined (GHCLIB_API_904) || defined(GHCLIB_API_902) - | not associate_right = L loc (OpApp noAnn e1 op1 e2)-- We *want* right association. -#else | not associate_right = L loc (OpApp noExt e1 op1 e2)-- We *want* right association. -#endif where (_, associate_right) = compareFixity fix1 negateFixity -- Default case, no rearrangment. -#if defined(GHCLIB_API_HEAD) || defined (GHCLIB_API_904) || defined(GHCLIB_API_902) -mkOpApp _ loc e1 op _fix e2 = L loc (OpApp noAnn e1 op e2) -#else mkOpApp _ loc e1 op _fix e2 = L loc (OpApp noExt e1 op e2) -#endif getIdent :: LHsExpr GhcPs -> String getIdent (unLoc -> HsVar _ (L _ n)) = occNameString . rdrNameOcc $ n getIdent _ = error "Must be HsVar" --- If there are no fixities, give 'baseFixities'. +-- If there are no fixities provided, give 'baseFixities. getFixities :: [(String, Fixity)] -> [(String, Fixity)] getFixities fixities = if null fixities then baseFixities else fixities findFixity :: [(String, Fixity)] -> LHsExpr GhcPs -> Fixity findFixity fs r = askFix fs (getIdent r) -- Expressions. -#if defined(GHCLIB_API_HEAD) || defined (GHCLIB_API_904) || defined(GHCLIB_API_902) -findFixity' :: [(String, Fixity)] -> LocatedN RdrName -> Fixity -#else findFixity' :: [(String, Fixity)] -> Located RdrName -> Fixity -#endif findFixity' fs r = askFix fs (occNameString . rdrNameOcc . unLoc $ r) -- Patterns. askFix :: [(String, Fixity)] -> String -> Fixity @@ -234,18 +146,16 @@ -- this list is that of Control.Arrows. baseFixities :: [(String, Fixity)] baseFixities = preludeFixities ++ concat - [ infixr_ 9 ["Compose"] - , infixl_ 9 ["!","//","!:"] + [ infixl_ 9 ["!","//","!:"] , infixl_ 8 ["shift","rotate","shiftL","shiftR","rotateL","rotateR"] , infixl_ 7 [".&."] , infixl_ 6 ["xor"] , infix_ 6 [":+"] - , infixr_ 6 ["<>"] , infixl_ 5 [".|."] - , infixr_ 5 ["+:+","<++","<+>","<|"] -- Fixity conflict for +++ between ReadP and Arrow. + , infixr_ 5 ["+:+","<++","<+>"] -- Fixity conflict for +++ between ReadP and Arrow. , infix_ 5 ["\\\\"] - , infixl_ 4 ["<$>","<$","$>","<*>","<*","*>","<**>","<$!>"] - , infix_ 4 ["elemP","notElemP",":~:", ":~~:"] + , infixl_ 4 ["<$>","<$","<*>","<*","*>","<**>"] + , infix_ 4 ["elemP","notElemP"] , infixl_ 3 ["<|>"] , infixr_ 3 ["&&&","***"] , infixr_ 2 ["+++","|||"] @@ -261,23 +171,3 @@ fixity :: FixityDirection -> Int -> [String] -> [(String, Fixity)] fixity a p = map (,Fixity (SourceText "") p a) - -#if defined (GHCLIB_API_904) || defined(GHCLIB_API_902) || defined (GHCLIB_API_900) -fixitiesFromModule :: Located HsModule -> [(String, Fixity)] -#else -fixitiesFromModule :: Located (HsModule GhcPs) -> [(String, Fixity)] -#endif -#if defined (GHCLIB_API_HEAD) -fixitiesFromModule (L _ (HsModule _ _ _ _ decls)) = concatMap f decls -#elif defined (GHCLIB_API_904) || defined(GHCLIB_API_902) -fixitiesFromModule (L _ (HsModule _ _ _ _ _ decls _ _)) = concatMap f decls -#elif defined (GHCLIB_API_900) -fixitiesFromModule (L _ (HsModule _ _ _ _ decls _ _)) = concatMap f decls -#else -fixitiesFromModule (L _ (HsModule _ _ _ decls _ _)) = concatMap f decls -#endif - where - f :: LHsDecl GhcPs -> [(String, Fixity)] - f (L _ (SigD _ (FixSig _ (FixitySig _ ops (Fixity _ p dir))))) = - fixity dir p (map (occNameString. rdrNameOcc . unLoc) ops) - f _ = [] diff --git a/src/Language/Haskell/GhclibParserEx/GHC/Driver/Flags.hs b/src/Language/Haskell/GhclibParserEx/GHC/Driver/Flags.hs deleted file mode 100644 --- a/src/Language/Haskell/GhclibParserEx/GHC/Driver/Flags.hs +++ /dev/null @@ -1,16 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# OPTIONS_GHC -Wno-orphans #-} -#include "ghclib_api.h" -module Language.Haskell.GhclibParserEx.GHC.Driver.Flags () where - -#if !(defined (GHCLIB_API_HEAD) || defined(GHCLIB_API_904) || defined(GHCLIB_API_902) || defined (GHCLIB_API_900)) -import DynFlags -#endif - --- This instance landed in --- https://gitlab.haskell.org/ghc/ghc/merge_requests/2905. -#if defined(GHCLIB_API_808) || defined(GHCLIB_API_810) -instance Bounded Language where - minBound = Haskell98 - maxBound = Haskell2010 -#endif diff --git a/src/Language/Haskell/GhclibParserEx/GHC/Driver/Session.hs b/src/Language/Haskell/GhclibParserEx/GHC/Driver/Session.hs deleted file mode 100644 --- a/src/Language/Haskell/GhclibParserEx/GHC/Driver/Session.hs +++ /dev/null @@ -1,182 +0,0 @@ --- Copyright (c) 2020, Shayne Fletcher. All rights reserved. --- SPDX-License-Identifier: BSD-3-Clause. - -{-# LANGUAGE CPP #-} -{-# OPTIONS_GHC -Wno-orphans #-} -#include "ghclib_api.h" -module Language.Haskell.GhclibParserEx.GHC.Driver.Session( - readExtension - , extensionImplications --- Landed in https://gitlab.haskell.org/ghc/ghc/merge_requests/2654. -#if defined (GHCLIB_API_808) || defined (GHCLIB_API_810) - , TurnOnFlag, turnOn, turnOff, impliedGFlags, impliedOffGFlags, impliedXFlags -#endif - , parsePragmasIntoDynFlags - ) where - -#if defined (GHCLIB_API_808) || defined (GHCLIB_API_810) -import qualified GHC.LanguageExtensions as LangExt -#endif -#if defined (GHCLIB_API_HEAD) || defined (GHCLIB_API_904) || defined(GHCLIB_API_902) || defined (GHCLIB_API_900) -import GHC.Utils.Panic -import GHC.Parser.Header -import GHC.Data.StringBuffer -import GHC.Driver.Session -#if defined (GHCLIB_API_HEAD) || defined (GHCLIB_API_904) || defined(GHCLIB_API_902) -import GHC.Types.SourceError -#else -import GHC.Driver.Types -#endif -#else -import Panic -import HeaderInfo -import StringBuffer -import DynFlags -import HscTypes -#endif -import GHC.LanguageExtensions.Type -import Data.List -import Data.Maybe -import qualified Data.Map as Map --- Landed in https://gitlab.haskell.org/ghc/ghc/merge_requests/2707. -#if defined (GHCLIB_API_808) || defined (GHCLIB_API_810) -import Data.Function -- For `compareOn`. -instance Ord Extension where - compare = compare `on` fromEnum -#endif -#if defined (GHCLIB_API_HEAD) || defined (GHCLIB_API_904) -import GHC.Driver.Config.Parser -#endif - --- | Parse a GHC extension. -readExtension :: String -> Maybe Extension -readExtension s = flagSpecFlag <$> find (\(FlagSpec n _ _ _) -> n == s) xFlags - --- | Implicitly enabled/disabled extensions. -extensionImplications :: [(Extension, ([Extension], [Extension]))] -extensionImplications = map f $ Map.toList implicationsMap - where - f (e, ps) = (fromJust (readExtension e), ps) - implicationsMap :: Map.Map String ([Extension], [Extension]) - implicationsMap = Map.fromListWith (<>) - [(show a, ([c | b], [c | not b])) - | (a, flag, c) <- impliedXFlags, let b = flag == turnOn] - --- Landed in --- https://gitlab.haskell.org/ghc/ghc/merge_requests/2654. Copied from --- 'ghc/compiler/main/DynFlags.hs'. -#if defined(GHCLIB_API_808) || defined(GHCLIB_API_810) - -type TurnOnFlag = Bool -- True <=> we are turning the flag on - -- False <=> we are turning the flag off -turnOn :: TurnOnFlag; turnOn = True -turnOff :: TurnOnFlag; turnOff = False - --- General flags that are switched on/off when other general flags are switched --- on -impliedGFlags :: [(GeneralFlag, TurnOnFlag, GeneralFlag)] -impliedGFlags = [(Opt_DeferTypeErrors, turnOn, Opt_DeferTypedHoles) - ,(Opt_DeferTypeErrors, turnOn, Opt_DeferOutOfScopeVariables) - ,(Opt_Strictness, turnOn, Opt_WorkerWrapper) - ,(Opt_UnclutterValidHoleFits, turnOff, Opt_ShowTypeAppOfHoleFits) - ,(Opt_UnclutterValidHoleFits, turnOff, Opt_ShowTypeAppVarsOfHoleFits) - ,(Opt_UnclutterValidHoleFits, turnOff, Opt_ShowDocsOfHoleFits) - ,(Opt_ShowTypeAppVarsOfHoleFits, turnOff, Opt_ShowTypeAppOfHoleFits) - ,(Opt_UnclutterValidHoleFits, turnOff, Opt_ShowProvOfHoleFits)] - --- General flags that are switched on/off when other general flags are switched --- off -impliedOffGFlags :: [(GeneralFlag, TurnOnFlag, GeneralFlag)] -impliedOffGFlags = [(Opt_Strictness, turnOff, Opt_WorkerWrapper)] - -impliedXFlags :: [(LangExt.Extension, TurnOnFlag, LangExt.Extension)] -impliedXFlags --- See Note [Updating flag description in the User's Guide] - = [ (LangExt.RankNTypes, turnOn, LangExt.ExplicitForAll) - , (LangExt.QuantifiedConstraints, turnOn, LangExt.ExplicitForAll) - , (LangExt.ScopedTypeVariables, turnOn, LangExt.ExplicitForAll) - , (LangExt.LiberalTypeSynonyms, turnOn, LangExt.ExplicitForAll) - , (LangExt.ExistentialQuantification, turnOn, LangExt.ExplicitForAll) - , (LangExt.FlexibleInstances, turnOn, LangExt.TypeSynonymInstances) - , (LangExt.FunctionalDependencies, turnOn, LangExt.MultiParamTypeClasses) - , (LangExt.MultiParamTypeClasses, turnOn, LangExt.ConstrainedClassMethods) -- c.f. #7854 - , (LangExt.TypeFamilyDependencies, turnOn, LangExt.TypeFamilies) - - , (LangExt.RebindableSyntax, turnOff, LangExt.ImplicitPrelude) -- NB: turn off! - - , (LangExt.DerivingVia, turnOn, LangExt.DerivingStrategies) - - , (LangExt.GADTs, turnOn, LangExt.GADTSyntax) - , (LangExt.GADTs, turnOn, LangExt.MonoLocalBinds) - , (LangExt.TypeFamilies, turnOn, LangExt.MonoLocalBinds) - - , (LangExt.TypeFamilies, turnOn, LangExt.KindSignatures) -- Type families use kind signatures - , (LangExt.PolyKinds, turnOn, LangExt.KindSignatures) -- Ditto polymorphic kinds - - -- TypeInType is now just a synonym for a couple of other extensions. - , (LangExt.TypeInType, turnOn, LangExt.DataKinds) - , (LangExt.TypeInType, turnOn, LangExt.PolyKinds) - , (LangExt.TypeInType, turnOn, LangExt.KindSignatures) - -#if defined(GHCLIB_API_810) - -- Standalone kind signatures are a replacement for CUSKs. - , (LangExt.StandaloneKindSignatures, turnOff, LangExt.CUSKs) -#endif - - -- AutoDeriveTypeable is not very useful without DeriveDataTypeable - , (LangExt.AutoDeriveTypeable, turnOn, LangExt.DeriveDataTypeable) - - -- We turn this on so that we can export associated type - -- type synonyms in subordinates (e.g. MyClass(type AssocType)) - , (LangExt.TypeFamilies, turnOn, LangExt.ExplicitNamespaces) - , (LangExt.TypeOperators, turnOn, LangExt.ExplicitNamespaces) - - , (LangExt.ImpredicativeTypes, turnOn, LangExt.RankNTypes) - - -- Record wild-cards implies field disambiguation - -- Otherwise if you write (C {..}) you may well get - -- stuff like " 'a' not in scope ", which is a bit silly - -- if the compiler has just filled in field 'a' of constructor 'C' - , (LangExt.RecordWildCards, turnOn, LangExt.DisambiguateRecordFields) - - , (LangExt.ParallelArrays, turnOn, LangExt.ParallelListComp) - - , (LangExt.JavaScriptFFI, turnOn, LangExt.InterruptibleFFI) - - , (LangExt.DeriveTraversable, turnOn, LangExt.DeriveFunctor) - , (LangExt.DeriveTraversable, turnOn, LangExt.DeriveFoldable) - - -- Duplicate record fields require field disambiguation - , (LangExt.DuplicateRecordFields, turnOn, LangExt.DisambiguateRecordFields) - - , (LangExt.TemplateHaskell, turnOn, LangExt.TemplateHaskellQuotes) - , (LangExt.Strict, turnOn, LangExt.StrictData) - ] -#endif - -parsePragmasIntoDynFlags :: DynFlags - -> ([Extension], [Extension]) - -> FilePath - -> String - -> IO (Either String DynFlags) -parsePragmasIntoDynFlags flags (enable, disable) file str = - catchErrors $ do -#if defined (GHCLIB_API_HEAD) || defined (GHCLIB_API_904) - let (_, opts) = - getOptions (initParserOpts flags) (stringToStringBuffer str) file -#else - let opts = - getOptions flags (stringToStringBuffer str) file -#endif - - -- Important : apply enables, disables *before* parsing dynamic - -- file pragmas. - let flags' = foldl' xopt_set flags enable - let flags'' = foldl' xopt_unset flags' disable - (flags, _, _) <- parseDynamicFilePragma flags'' opts - return $ Right (flags `gopt_set` Opt_KeepRawTokenStream) - where - catchErrors :: IO (Either String DynFlags) -> IO (Either String DynFlags) - catchErrors act = handleGhcException reportErr - (handleSourceError reportErr act) - reportErr e = return $ Left (show e) diff --git a/src/Language/Haskell/GhclibParserEx/GHC/Hs.hs b/src/Language/Haskell/GhclibParserEx/GHC/Hs.hs deleted file mode 100644 --- a/src/Language/Haskell/GhclibParserEx/GHC/Hs.hs +++ /dev/null @@ -1,34 +0,0 @@ --- Copyright (c) 2020, Shayne Fletcher. All rights reserved. --- SPDX-License-Identifier: BSD-3-Clause. - -{-# LANGUAGE CPP #-} -#include "ghclib_api.h" - -module Language.Haskell.GhclibParserEx.GHC.Hs( - modName - ) -where - -#if defined (GHCLIB_API_HEAD) || defined (GHCLIB_API_904) || defined (GHCLIB_API_902) || defined (GHCLIB_API_900) -import GHC.Hs -# if !defined (GHCLIB_API_HEAD) -import GHC.Unit.Module -# endif -import GHC.Types.SrcLoc -#elif defined (GHCLIB_API_810) -import GHC.Hs -import Module -import SrcLoc -#else -import HsSyn -import Module -import SrcLoc -#endif - -#if defined (GHCLIB_API_904) || defined (GHCLIB_API_902) || defined (GHCLIB_API_900) -modName :: Located HsModule -> String -#else -modName :: Located (HsModule GhcPs) -> String -#endif -modName (L _ HsModule {hsmodName=Nothing}) = "Main" -modName (L _ HsModule {hsmodName=Just (L _ n)}) = moduleNameString n diff --git a/src/Language/Haskell/GhclibParserEx/GHC/Hs/Binds.hs b/src/Language/Haskell/GhclibParserEx/GHC/Hs/Binds.hs deleted file mode 100644 --- a/src/Language/Haskell/GhclibParserEx/GHC/Hs/Binds.hs +++ /dev/null @@ -1,20 +0,0 @@ --- Copyright (c) 2020, Shayne Fletcher. All rights reserved. --- SPDX-License-Identifier: BSD-3-Clause. -{-# LANGUAGE CPP #-} -#include "ghclib_api.h" -module Language.Haskell.GhclibParserEx.GHC.Hs.Binds( - isPatSynBind - ) -where - -#if defined (GHCLIB_API_HEAD) || defined (GHCLIB_API_904) || defined(GHCLIB_API_902) || defined (GHCLIB_API_900) || defined (GHCLIB_API_810) -import GHC.Hs.Binds -import GHC.Hs.Extension -#else -import HsBinds -import HsExtension -#endif - -isPatSynBind :: HsBind GhcPs -> Bool -isPatSynBind PatSynBind{} = True -isPatSynBind _ = False diff --git a/src/Language/Haskell/GhclibParserEx/GHC/Hs/Decls.hs b/src/Language/Haskell/GhclibParserEx/GHC/Hs/Decls.hs deleted file mode 100644 --- a/src/Language/Haskell/GhclibParserEx/GHC/Hs/Decls.hs +++ /dev/null @@ -1,30 +0,0 @@ --- Copyright (c) 2020, Shayne Fletcher. All rights reserved. --- SPDX-License-Identifier: BSD-3-Clause. - -{-# LANGUAGE CPP #-} -#include "ghclib_api.h" -module Language.Haskell.GhclibParserEx.GHC.Hs.Decls( - isNewType, isForD, isDerivD, isClsDefSig - ) where - -#if defined (GHCLIB_API_HEAD) || defined (GHCLIB_API_904) || defined(GHCLIB_API_902) || defined (GHCLIB_API_900) || defined (GHCLIB_API_810) -import GHC.Hs -#else -import HsSyn -#endif -#if defined (GHCLIB_API_HEAD) || defined (GHCLIB_API_904) || defined(GHCLIB_API_902) || defined (GHCLIB_API_900) -import GHC.Types.SrcLoc -#else -import SrcLoc -#endif - -isNewType :: NewOrData -> Bool -isNewType NewType = True -isNewType DataType = False - -isForD, isDerivD :: LHsDecl GhcPs -> Bool -isForD (L _ ForD{}) = True; isForD _ = False -isDerivD (L _ DerivD{}) = True; isDerivD _ = False - -isClsDefSig :: Sig GhcPs -> Bool -isClsDefSig (ClassOpSig _ True _ _) = True; isClsDefSig _ = False diff --git a/src/Language/Haskell/GhclibParserEx/GHC/Hs/Expr.hs b/src/Language/Haskell/GhclibParserEx/GHC/Hs/Expr.hs deleted file mode 100644 --- a/src/Language/Haskell/GhclibParserEx/GHC/Hs/Expr.hs +++ /dev/null @@ -1,254 +0,0 @@ --- Copyright (c) 2020, Shayne Fletcher. All rights reserved. --- SPDX-License-Identifier: BSD-3-Clause. - -{-# OPTIONS_GHC -Wno-missing-fields #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE LambdaCase #-} -#include "ghclib_api.h" -module Language.Haskell.GhclibParserEx.GHC.Hs.Expr( - isTag, isDol, isDot, isReturn, isSection, isRecConstr, isRecUpdate, - isVar, isPar, isApp, isOpApp, isAnyApp, isLexeme, isLambda, isQuasiQuote, isQuasiQuoteExpr, isQuasiQuoteSplice, isOverLabel, - isDotApp, isTypeApp, isWHNF, isLCase, - isFieldPun, isFieldPunUpdate, isRecStmt, isParComp, isMDo, isListComp, isMonadComp, isTupleSection, isString, isPrimLiteral, - isSpliceDecl, isFieldWildcard, isUnboxed, isWholeFrac, isStrictMatch, isMultiIf, isProc, isTransStmt, - hasFieldsDotDot, - varToStr, strToVar, - fromChar - ) where - -#if defined (GHCLIB_API_HEAD) || defined (GHCLIB_API_904) || defined(GHCLIB_API_902) || defined (GHCLIB_API_900) || defined (GHCLIB_API_810) -import GHC.Hs -#else -import HsSyn -#endif -#if defined (GHCLIB_API_HEAD) || defined (GHCLIB_API_904) || defined(GHCLIB_API_902) || defined (GHCLIB_API_900) -#if defined (GHCLIB_API_HEAD) || defined (GHCLIB_API_904) || defined(GHCLIB_API_902) -import GHC.Types.SourceText -#endif -import GHC.Types.SrcLoc -import GHC.Types.Name.Reader -import GHC.Types.Name -import GHC.Types.Basic -import GHC.Builtin.Types -#else -import SrcLoc -import RdrName -import OccName -import Name -import BasicTypes -import TysWiredIn -#endif -import Data.Ratio - --- 'True' if the provided expression is a variable with name 'tag'. -isTag :: String -> LHsExpr GhcPs -> Bool -isTag tag = \case (L _ (HsVar _ (L _ s))) -> occNameString (rdrNameOcc s) == tag; _ -> False - -isDot, isDol, isReturn, isSection, isRecConstr, isRecUpdate, - isVar, isPar, isApp, isOpApp, isAnyApp, isLexeme, isQuasiQuote, isQuasiQuoteExpr, - isLambda, isDotApp, isTypeApp, isWHNF, isLCase, isOverLabel :: LHsExpr GhcPs -> Bool -isDol = isTag "$" -isDot = isTag "." -isReturn x = isTag "return" x || isTag "pure" x -- Allow both 'pure' and 'return' as they have the same semantics. -isSection = \case (L _ SectionL{}) -> True ; (L _ SectionR{}) -> True; _ -> False -isRecConstr = \case (L _ RecordCon{}) -> True; _ -> False -isRecUpdate = \case (L _ RecordUpd{}) -> True; _ -> False -isVar = \case (L _ HsVar{}) -> True; _ -> False -isPar = \case (L _ HsPar{}) -> True; _ -> False -isApp = \case (L _ HsApp{}) -> True; _ -> False -isOpApp = \case (L _ OpApp{}) -> True; _ -> False -isAnyApp x = isApp x || isOpApp x -isLexeme = \case (L _ HsVar{}) -> True; (L _ HsOverLit{}) -> True; (L _ HsLit{}) -> True; _ -> False -isLambda = \case (L _ HsLam{}) -> True; _ -> False -#if defined (GHCLIB_API_HEAD) -isQuasiQuoteExpr = \case (L _ (HsUntypedSplice _ HsQuasiQuote{})) -> True; _ -> False -#else -isQuasiQuoteExpr = \case (L _ (HsSpliceE _ HsQuasiQuote{})) -> True; _ -> False -#endif -isQuasiQuote = isQuasiQuoteExpr -- Backwards compat. -isDotApp = \case (L _ (OpApp _ _ op _)) -> isDot op; _ -> False -isTypeApp = \case (L _ HsAppType{}) -> True; _ -> False -isWHNF = \case - (L _ (HsVar _ (L _ x))) -> isRdrDataCon x - (L _ (HsLit _ x)) -> case x of HsString{} -> False; HsInt{} -> False; HsRat{} -> False; _ -> True - (L _ HsLam{}) -> True - (L _ ExplicitTuple{}) -> True - (L _ ExplicitList{}) -> True -#if defined (GHCLIB_API_HEAD) || defined (GHCLIB_API_904) - (L _ (HsPar _ _ x _)) -> isWHNF x -#else - (L _ (HsPar _ x)) -> isWHNF x -#endif - (L _ (ExprWithTySig _ x _)) -> isWHNF x - -- Other (unknown) constructors may have bang patterns in them, so - -- approximate. - (L _ (HsApp _ (L _ (HsVar _ (L _ x))) _)) - | occNameString (rdrNameOcc x) `elem` ["Just", "Left", "Right"] -> True - _ -> False -isLCase = \case (L _ HsLamCase{}) -> True; _ -> False -isOverLabel = \case (L _ HsOverLabel{}) -> True; _ -> False - -#if defined (GHCLIB_API_HEAD) -isQuasiQuoteSplice :: HsUntypedSplice GhcPs -> Bool -#else -isQuasiQuoteSplice :: HsSplice GhcPs -> Bool -#endif -isQuasiQuoteSplice = \case HsQuasiQuote{} -> True; _ -> False - - -#if defined (GHCLIB_API_HEAD) || defined (GHCLIB_API_904) || defined(GHCLIB_API_902) || defined (GHCLIB_API_901) -isStrictMatch :: HsMatchContext GhcPs -> Bool -#else -isStrictMatch :: HsMatchContext RdrName -> Bool -#endif -isStrictMatch = \case FunRhs{mc_strictness=SrcStrict} -> True; _ -> False - --- Field is punned e.g. '{foo}'. -#if defined (GHCLIB_API_HEAD) || defined (GHCLIB_API_904) -isFieldPun :: LHsFieldBind GhcPs (LFieldOcc GhcPs) (LHsExpr GhcPs) -> Bool -isFieldPun = \case (L _ HsFieldBind {hfbPun=True}) -> True; _ -> False -#else -isFieldPun :: LHsRecField GhcPs (LHsExpr GhcPs) -> Bool -isFieldPun = \case (L _ HsRecField {hsRecPun=True}) -> True; _ -> False -#endif --- Field puns in updates have a different type to field puns in --- constructions. -#if defined (GHCLIB_API_HEAD) || defined (GHCLIB_API_904) -isFieldPunUpdate :: HsFieldBind (LAmbiguousFieldOcc GhcPs) (LHsExpr GhcPs) -> Bool -isFieldPunUpdate = \case HsFieldBind {hfbPun=True} -> True; _ -> False -#else -isFieldPunUpdate :: HsRecField' (AmbiguousFieldOcc GhcPs) (LHsExpr GhcPs) -> Bool -isFieldPunUpdate = \case HsRecField {hsRecPun=True} -> True; _ -> False -#endif - --- Contains a '..' as in 'Foo{..}' -hasFieldsDotDot :: HsRecFields GhcPs (LHsExpr GhcPs) -> Bool -hasFieldsDotDot = \case HsRecFields {rec_dotdot=Just _} -> True; _ -> False - -isRecStmt :: StmtLR GhcPs GhcPs (LHsExpr GhcPs) -> Bool -isRecStmt = \case RecStmt{} -> True; _ -> False - -isParComp :: StmtLR GhcPs GhcPs (LHsExpr GhcPs) -> Bool -isParComp = \case ParStmt{} -> True; _ -> False - --- TODO: Seems `HsStmtContext (HsDoRn p)` on master right now. -#if defined (GHCLIB_API_HEAD) || defined (GHCLIB_API_904) -isMDo :: HsDoFlavour -> Bool -isMDo = \case MDoExpr _ -> True; _ -> False -isMonadComp :: HsDoFlavour -> Bool -isMonadComp = \case MonadComp -> True; _ -> False -isListComp :: HsDoFlavour -> Bool -isListComp = \case ListComp -> True; _ -> False -#elif defined(GHCLIB_API_902) || defined (GHCLIB_API_900) -isMDo :: HsStmtContext GhcRn -> Bool -isMDo = \case MDoExpr _ -> True; _ -> False -isMonadComp :: HsStmtContext GhcRn -> Bool -isMonadComp = \case MonadComp -> True; _ -> False -isListComp :: HsStmtContext GhcRn -> Bool -isListComp = \case ListComp -> True; _ -> False -#else -isMDo :: HsStmtContext Name -> Bool -isMDo = \case MDoExpr -> True; _ -> False -isMonadComp :: HsStmtContext Name -> Bool -isMonadComp = \case MonadComp -> True; _ -> False -isListComp :: HsStmtContext Name -> Bool -isListComp = \case ListComp -> True; _ -> False -#endif - -isTupleSection :: HsTupArg GhcPs -> Bool -isTupleSection = \case Missing{} -> True; _ -> False - -isString :: HsLit GhcPs -> Bool -isString = \case HsString{} -> True; _ -> False - -isPrimLiteral :: HsLit GhcPs -> Bool -isPrimLiteral = \case - HsCharPrim{} -> True - HsStringPrim{} -> True - HsIntPrim{} -> True - HsWordPrim{} -> True - HsInt64Prim{} -> True - HsWord64Prim{} -> True - HsFloatPrim{} -> True - HsDoublePrim{} -> True - _ -> False - -isSpliceDecl :: HsExpr GhcPs -> Bool -#if defined (GHCLIB_API_HEAD) -isSpliceDecl = \case - HsTypedSplice{} -> True - HsUntypedSplice{} -> True - _ -> False -#else -isSpliceDecl = \case HsSpliceE{} -> True; _ -> False -#endif - -isMultiIf :: HsExpr GhcPs -> Bool -isMultiIf = \case HsMultiIf{} -> True; _ -> False - -isProc :: HsExpr GhcPs -> Bool -isProc = \case HsProc{} -> True; _ -> False - -isTransStmt :: StmtLR GhcPs GhcPs (LHsExpr GhcPs) -> Bool -isTransStmt = \case TransStmt{} -> True; _ -> False - --- Field has a '_' as in '{foo=_} or is punned e.g. '{foo}'. -#if defined (GHCLIB_API_HEAD) || defined (GHCLIB_API_904) -isFieldWildcard :: LHsFieldBind GhcPs (LFieldOcc GhcPs) (LHsExpr GhcPs) -> Bool -#else -isFieldWildcard :: LHsRecField GhcPs (LHsExpr GhcPs) -> Bool -#endif -isFieldWildcard = \case -#if defined (GHCLIB_API_HEAD) || defined (GHCLIB_API_904) - (L _ HsFieldBind {hfbRHS=(L _ (HsUnboundVar _ s))}) -> occNameString s == "_" -#elif defined(GHCLIB_API_902) || defined (GHCLIB_API_900) - (L _ HsRecField {hsRecFieldArg=(L _ (HsUnboundVar _ s))}) -> occNameString s == "_" -#elif defined (GHCLIB_API_810) - (L _ HsRecField {hsRecFieldArg=(L _ (HsUnboundVar _ _))}) -> True -#else - (L _ HsRecField {hsRecFieldArg=(L _ (EWildPat _))}) -> True -#endif -#if defined (GHCLIB_API_HEAD) || defined (GHCLIB_API_904) - (L _ HsFieldBind {hfbPun=True}) -> True - (L _ HsFieldBind {}) -> False -#else - (L _ HsRecField {hsRecPun=True}) -> True - (L _ HsRecField {}) -> False -#endif - -isUnboxed :: Boxity -> Bool -isUnboxed = \case Unboxed -> True; _ -> False - -isWholeFrac :: HsExpr GhcPs -> Bool - -#if defined (GHCLIB_API_HEAD) || defined (GHCLIB_API_904) -isWholeFrac (HsLit _ (HsRat _ fl@FL{} _)) = denominator (rationalFromFractionalLit fl) == 1 -isWholeFrac (HsOverLit _ (OverLit _ (HsFractional fl@FL {}) )) = denominator (rationalFromFractionalLit fl) == 1 -#elif defined(GHCLIB_API_902) -isWholeFrac (HsLit _ (HsRat _ fl@FL{} _)) = denominator (rationalFromFractionalLit fl) == 1 -isWholeFrac (HsOverLit _ (OverLit _ (HsFractional fl@FL {}) _)) = denominator (rationalFromFractionalLit fl) == 1 -#else -isWholeFrac (HsLit _ (HsRat _ (FL _ _ v) _)) = denominator v == 1 -isWholeFrac (HsOverLit _ (OverLit _ (HsFractional (FL _ _ v)) _)) = denominator v == 1 -#endif -isWholeFrac _ = False - -varToStr :: LHsExpr GhcPs -> String -varToStr (L _ (HsVar _ (L _ n))) - | n == consDataCon_RDR = ":" - | n == nameRdrName nilDataConName = "[]" - | n == nameRdrName (getName (tupleDataCon Boxed 0)) = "()" - | otherwise = occNameString (rdrNameOcc n) -varToStr _ = "" - -strToVar :: String -> LHsExpr GhcPs -#if defined (GHCLIB_API_HEAD) || defined (GHCLIB_API_904) || defined(GHCLIB_API_902) -strToVar x = noLocA $ HsVar noExtField (noLocA $ mkRdrUnqual (mkVarOcc x)) -#elif defined (GHCLIB_API_900) || defined (GHCLIB_API_810) -strToVar x = noLoc $ HsVar noExtField (noLoc $ mkRdrUnqual (mkVarOcc x)) -#else -strToVar x = noLoc $ HsVar noExt (noLoc $ mkRdrUnqual (mkVarOcc x)) -#endif - -fromChar :: LHsExpr GhcPs -> Maybe Char -fromChar = \case (L _ (HsLit _ (HsChar _ x))) -> Just x; _ -> Nothing diff --git a/src/Language/Haskell/GhclibParserEx/GHC/Hs/ExtendInstances.hs b/src/Language/Haskell/GhclibParserEx/GHC/Hs/ExtendInstances.hs deleted file mode 100644 --- a/src/Language/Haskell/GhclibParserEx/GHC/Hs/ExtendInstances.hs +++ /dev/null @@ -1,64 +0,0 @@ --- Copyright (c) 2020, Shayne Fletcher. All rights reserved. --- SPDX-License-Identifier: BSD-3-Clause. - -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE CPP #-} -#include "ghclib_api.h" - -module Language.Haskell.GhclibParserEx.GHC.Hs.ExtendInstances ( - HsExtendInstances(..), extendInstances, astEq, astListEq) -where - --- At times, there are terms in Haskell syntax we work with that are --- not in `Eq`, `Show` or `Ord` and we need them to be. - --- This work-around resorts to implementing Eq and Ord via --- lexicographic string comparisons. As long as two different terms --- never map to the same string, basing `Eq` and `Ord` on their string --- representations rather than the terms themselves, leads to --- identical results. - -#if defined (GHCLIB_API_HEAD) || defined (GHCLIB_API_904) || defined(GHCLIB_API_902) || defined (GHCLIB_API_900) -import GHC.Utils.Outputable -#else -import Outputable -#endif -import Data.Data -import Data.Function -import Language.Haskell.GhclibParserEx.Dump - -newtype HsExtendInstances a = - HsExtendInstances { unextendInstances :: a } - deriving Outputable - -extendInstances :: a -> HsExtendInstances a -extendInstances = HsExtendInstances - --- Use 'showAstData'. This is preferable to 'ppr' in that trees that --- only differ in arrangement due to fixities will produce differing --- string representations. -toStr :: Data a => HsExtendInstances a -> String -toStr (HsExtendInstances e) = -#if defined (GHCLIB_API_HEAD) || defined (GHCLIB_API_904) || defined (GHCLIB_API_902) - showPprUnsafe $ showAstData BlankSrcSpan BlankEpAnnotations e -#else - showSDocUnsafe $ showAstData BlankSrcSpan e -#endif - -instance Data a => Eq (HsExtendInstances a) where (==) a b = toStr a == toStr b -instance Data a => Ord (HsExtendInstances a) where compare = compare `on` toStr - -astEq :: Data a => a -> a -> Bool -astEq a b = extendInstances a == extendInstances b - -astListEq :: Data a => [a] -> [a] -> Bool -astListEq as bs = length as == length bs && all (uncurry astEq) (zip as bs) - --- Use 'ppr' for 'Show'. -instance Outputable a => Show (HsExtendInstances a) where - show (HsExtendInstances e) = -#if defined(GHCLIB_API_HEAD) || defined(GHCLIB_API_902) - showPprUnsafe $ ppr e -#else - showSDocUnsafe $ ppr e -#endif diff --git a/src/Language/Haskell/GhclibParserEx/GHC/Hs/ImpExp.hs b/src/Language/Haskell/GhclibParserEx/GHC/Hs/ImpExp.hs deleted file mode 100644 --- a/src/Language/Haskell/GhclibParserEx/GHC/Hs/ImpExp.hs +++ /dev/null @@ -1,52 +0,0 @@ --- Copyright (c) 2020, Shayne Fletcher. All rights reserved. --- SPDX-License-Identifier: BSD-3-Clause. -{-# LANGUAGE CPP #-} -#include "ghclib_api.h" -module Language.Haskell.GhclibParserEx.GHC.Hs.ImpExp( - isPatSynIE -#if defined (MIN_VERSION_ghc_lib_parser) -# if !MIN_VERSION_ghc_lib_parser(1, 0, 0) || MIN_VERSION_ghc_lib_parser(8, 10, 0) - , isImportQualifiedPost -# endif -#elif __GLASGOW_HASKELL__ >= 810 - , isImportQualifiedPost -#endif - ) -where - -#if defined (GHCLIB_API_HEAD) -import GHC.Hs.Extension (GhcPs) -#endif - -#if defined (GHCLIB_API_HEAD) || defined (GHCLIB_API_904) || defined(GHCLIB_API_902) || defined (GHCLIB_API_900) -import GHC.Hs.ImpExp -# if !defined (GHCLIB_API_HEAD) -import GHC.Types.Name.Reader -# endif -#elif defined (GHCLIB_API_810) -import GHC.Hs.ImpExp -import RdrName -#else -import HsImpExp -import RdrName -#endif - -#if defined (GHCLIB_API_HEAD) -isPatSynIE :: IEWrappedName GhcPs -> Bool -#else -isPatSynIE :: IEWrappedName RdrName -> Bool -#endif -isPatSynIE IEPattern{} = True -isPatSynIE _ = False - -#if defined (MIN_VERSION_ghc_lib_parser) -# if !MIN_VERSION_ghc_lib_parser(1, 0, 0) || MIN_VERSION_ghc_lib_parser(8, 10, 0) -isImportQualifiedPost :: ImportDeclQualifiedStyle -> Bool -isImportQualifiedPost QualifiedPost = True -isImportQualifiedPost _ = False -# endif -#elif __GLASGOW_HASKELL__ >= 810 -isImportQualifiedPost :: ImportDeclQualifiedStyle -> Bool -isImportQualifiedPost QualifiedPost = True -isImportQualifiedPost _ = False -#endif diff --git a/src/Language/Haskell/GhclibParserEx/GHC/Hs/Pat.hs b/src/Language/Haskell/GhclibParserEx/GHC/Hs/Pat.hs deleted file mode 100644 --- a/src/Language/Haskell/GhclibParserEx/GHC/Hs/Pat.hs +++ /dev/null @@ -1,178 +0,0 @@ --- Copyright (c) 2020, Shayne Fletcher. All rights reserved. --- SPDX-License-Identifier: BSD-3-Clause. - -{-# LANGUAGE CPP #-} -{-# LANGUAGE ViewPatterns #-} -#include "ghclib_api.h" -module Language.Haskell.GhclibParserEx.GHC.Hs.Pat( - patToStr, strToPat - , fromPChar - , hasPFieldsDotDot - , isPFieldWildcard, isPWildcard, isPFieldPun, isPatTypeSig, isPBangPat, isPViewPat - , isSplicePat - ) where - -#if defined (GHCLIB_API_HEAD) || defined (GHCLIB_API_904) || defined (GHCLIB_API_902) || defined (GHCLIB_API_900) || defined (GHCLIB_API_810) -import GHC.Hs -#else -import HsSyn -#endif -#if defined (GHCLIB_API_HEAD) || defined (GHCLIB_API_904) || defined (GHCLIB_API_902) || defined (GHCLIB_API_900) -import GHC.Types.SrcLoc -import GHC.Builtin.Types -import GHC.Types.Name.Reader -import GHC.Types.Name -import GHC.Data.FastString -#else -import SrcLoc -import TysWiredIn -import RdrName -import OccName -import FastString -#endif - -patToStr :: LPat GhcPs -> String -#if defined (GHCLIB_API_HEAD) || defined (GHCLIB_API_904) || defined (GHCLIB_API_902) -patToStr (L _ (ConPat _ (L _ x) (PrefixCon [] []))) | occNameString (rdrNameOcc x) == "True" = "True" -patToStr (L _ (ConPat _ (L _ x) (PrefixCon [] []))) | occNameString (rdrNameOcc x) == "False" = "False" -patToStr (L _ (ConPat _ (L _ x) (PrefixCon [] []))) | occNameString (rdrNameOcc x) == "[]" = "[]" -patToStr _ = "" -#elif defined (GHCLIB_API_900) -patToStr (L _ (ConPat _ (L _ x) (PrefixCon []))) | occNameString (rdrNameOcc x) == "True" = "True" -patToStr (L _ (ConPat _ (L _ x) (PrefixCon []))) | occNameString (rdrNameOcc x) == "False" = "False" -patToStr (L _ (ConPat _ (L _ x) (PrefixCon []))) | occNameString (rdrNameOcc x) == "[]" = "[]" -patToStr _ = "" -#elif defined (GHCLIB_API_810) -patToStr (L _ (ConPatIn (L _ x) (PrefixCon []))) | occNameString (rdrNameOcc x) == "True" = "True" -patToStr (L _ (ConPatIn (L _ x) (PrefixCon []))) | occNameString (rdrNameOcc x) == "False" = "False" -patToStr (L _ (ConPatIn (L _ x) (PrefixCon []))) | occNameString (rdrNameOcc x) == "[]" = "[]" -patToStr _ = "" -#else -patToStr (dL -> L _ (ConPatIn (L _ x) (PrefixCon []))) | occNameString (rdrNameOcc x) == "True" = "True" -patToStr (dL -> L _ (ConPatIn (L _ x) (PrefixCon []))) | occNameString (rdrNameOcc x) == "False" = "False" -patToStr (dL -> L _ (ConPatIn (L _ x) (PrefixCon []))) | occNameString (rdrNameOcc x) == "[]" = "[]" -patToStr _ = "" -#endif - -strToPat :: String -> LPat GhcPs -strToPat z - | z == "True" = -#if defined (GHCLIB_API_HEAD) || defined (GHCLIB_API_904) || defined (GHCLIB_API_902) - noLocA $ -#elif defined (GHCLIB_API_900) || defined (GHCLIB_API_810) - noLoc $ -#endif -#if defined (GHCLIB_API_HEAD) || defined (GHCLIB_API_904) || defined (GHCLIB_API_902) - ConPat noAnn (noLocA true_RDR) (PrefixCon [] []) -#elif defined (GHCLIB_API_900) - ConPat noExtField (noLoc true_RDR) (PrefixCon []) -#else - ConPatIn (noLoc true_RDR) (PrefixCon []) -#endif - | z == "False" = -#if defined (GHCLIB_API_HEAD) || defined (GHCLIB_API_904) || defined (GHCLIB_API_902) - noLocA $ -#elif defined (GHCLIB_API_900) || defined (GHCLIB_API_810) - noLoc $ -#endif -#if defined (GHCLIB_API_HEAD) || defined (GHCLIB_API_904) || defined (GHCLIB_API_902) - ConPat noAnn (noLocA false_RDR) (PrefixCon [] []) -#elif defined (GHCLIB_API_900) - ConPat noExtField (noLoc false_RDR) (PrefixCon []) -#else - ConPatIn (noLoc false_RDR) (PrefixCon []) -#endif - | z == "[]" = -#if defined (GHCLIB_API_HEAD) || defined (GHCLIB_API_904) || defined (GHCLIB_API_902) - noLocA $ -#elif defined (GHCLIB_API_900) || defined (GHCLIB_API_810) - noLoc $ -#endif -#if defined (GHCLIB_API_HEAD) || defined (GHCLIB_API_904) || defined (GHCLIB_API_902) - ConPat noAnn (noLocA $ nameRdrName nilDataConName) (PrefixCon [] []) -#elif defined (GHCLIB_API_900) - ConPat noExtField (noLoc $ nameRdrName nilDataConName) (PrefixCon []) -#else - ConPatIn (noLoc $ nameRdrName nilDataConName) (PrefixCon []) -#endif - | otherwise = -#if defined (GHCLIB_API_HEAD) || defined (GHCLIB_API_904) || defined (GHCLIB_API_902) - noLocA $ VarPat noExtField (noLocA $ mkVarUnqual (fsLit z)) -#elif defined (GHCLIB_API_900) || defined (GHCLIB_API_810) - noLoc $ VarPat noExtField (noLoc $ mkVarUnqual (fsLit z)) -#else - VarPat noExt (noLoc $ mkVarUnqual (fsLit z)) -#endif - -fromPChar :: LPat GhcPs -> Maybe Char -#if defined (GHCLIB_API_HEAD) || defined (GHCLIB_API_904) || defined (GHCLIB_API_902) || defined (GHCLIB_API_900) || defined (GHCLIB_API_810) -fromPChar (L _ (LitPat _ (HsChar _ x))) = Just x -#else -fromPChar (dL -> L _ (LitPat _ (HsChar _ x))) = Just x -#endif -fromPChar _ = Nothing - --- Contains a '..' as in 'Foo{..}' -hasPFieldsDotDot :: HsRecFields GhcPs (LPat GhcPs) -> Bool -hasPFieldsDotDot HsRecFields {rec_dotdot=Just _} = True -hasPFieldsDotDot _ = False - --- Field has a '_' as in '{foo=_} or is punned e.g. '{foo}'. -#if defined (GHCLIB_API_HEAD) || defined (GHCLIB_API_904) -isPFieldWildcard :: LHsFieldBind GhcPs (LFieldOcc GhcPs) (LPat GhcPs) -> Bool -#else -isPFieldWildcard :: LHsRecField GhcPs (LPat GhcPs) -> Bool -#endif -#if defined (GHCLIB_API_HEAD) || defined (GHCLIB_API_904) -isPFieldWildcard (L _ HsFieldBind {hfbRHS=L _ WildPat {}}) = True -isPFieldWildcard (L _ HsFieldBind {hfbPun=True}) = True -isPFieldWildcard (L _ HsFieldBind {}) = False -#elif defined (GHCLIB_API_902) || defined (GHCLIB_API_900) || defined (GHCLIB_API_810) -isPFieldWildcard (L _ HsRecField {hsRecFieldArg=L _ WildPat {}}) = True -isPFieldWildcard (L _ HsRecField {hsRecPun=True}) = True -isPFieldWildcard (L _ HsRecField {}) = False -#else -isPFieldWildcard (dL -> L _ HsRecField {hsRecFieldArg=LL _ WildPat {}}) = True -isPFieldWildcard (dL -> L _ HsRecField {hsRecPun=True}) = True -isPFieldWildcard (dL -> L _ HsRecField {}) = False -#endif - -isPWildcard :: LPat GhcPs -> Bool -#if defined (GHCLIB_API_HEAD) || defined (GHCLIB_API_904) || defined (GHCLIB_API_902) || defined (GHCLIB_API_900) || defined (GHCLIB_API_810) -isPWildcard (L _ (WildPat _)) = True -#else -isPWildcard (dL -> L _ (WildPat _)) = True -#endif -isPWildcard _ = False - -#if defined (GHCLIB_API_HEAD) || defined (GHCLIB_API_904) -isPFieldPun :: LHsFieldBind GhcPs (LFieldOcc GhcPs) (LPat GhcPs) -> Bool -#else -isPFieldPun :: LHsRecField GhcPs (LPat GhcPs) -> Bool -#endif -#if defined (GHCLIB_API_HEAD) || defined (GHCLIB_API_904) -isPFieldPun (L _ HsFieldBind {hfbPun=True}) = True -#elif defined (GHCLIB_API_902) || defined (GHCLIB_API_900) || defined (GHCLIB_API_810) -isPFieldPun (L _ HsRecField {hsRecPun=True}) = True -#else -isPFieldPun (dL -> L _ HsRecField {hsRecPun=True}) = True -#endif -isPFieldPun _ = False - -isPatTypeSig, isPBangPat, isPViewPat :: LPat GhcPs -> Bool -#if defined (GHCLIB_API_HEAD) || defined (GHCLIB_API_904) || defined (GHCLIB_API_902) || defined (GHCLIB_API_900) || defined (GHCLIB_API_810) -isPatTypeSig (L _ SigPat{}) = True; isPatTypeSig _ = False -isPBangPat (L _ BangPat{}) = True; isPBangPat _ = False -isPViewPat (L _ ViewPat{}) = True; isPViewPat _ = False -#else -isPatTypeSig (dL -> L _ SigPat{}) = True; isPatTypeSig _ = False -isPBangPat (dL -> L _ BangPat{}) = True; isPBangPat _ = False -isPViewPat (dL -> L _ ViewPat{}) = True; isPViewPat _ = False -#endif - -isSplicePat :: LPat GhcPs -> Bool -#if defined (GHCLIB_API_HEAD) || defined (GHCLIB_API_904) || defined (GHCLIB_API_902) || defined (GHCLIB_API_900) || defined (GHCLIB_API_810) -isSplicePat (L _ SplicePat{}) = True; isSplicePat _ = False -#else -isSplicePat (dL -> L _ SplicePat{}) = True; isSplicePat _ = False -#endif diff --git a/src/Language/Haskell/GhclibParserEx/GHC/Hs/Type.hs b/src/Language/Haskell/GhclibParserEx/GHC/Hs/Type.hs deleted file mode 100644 --- a/src/Language/Haskell/GhclibParserEx/GHC/Hs/Type.hs +++ /dev/null @@ -1,36 +0,0 @@ --- Copyright (c) 2021, Shayne Fletcher. All rights reserved. --- SPDX-License-Identifier: BSD-3-Clause. - -{-# LANGUAGE CPP #-} -{-# LANGUAGE LambdaCase #-} -#include "ghclib_api.h" -module Language.Haskell.GhclibParserEx.GHC.Hs.Type ( - fromTyParen - , isTyQuasiQuote, isUnboxedTuple, isKindTyApp -) where - -#if defined (GHCLIB_API_HEAD) || defined (GHCLIB_API_904) || defined (GHCLIB_API_902) || defined (GHCLIB_API_900) || defined (GHCLIB_API_810) -import GHC.Hs -#else -import HsSyn -#endif -#if defined (GHCLIB_API_HEAD) || defined (GHCLIB_API_904) || defined (GHCLIB_API_902) || defined (GHCLIB_API_900) -import GHC.Types.SrcLoc -#else -import SrcLoc -#endif - -isKindTyApp :: LHsType GhcPs -> Bool -isKindTyApp = \case (L _ HsAppKindTy{}) -> True; _ -> False - -fromTyParen :: LHsType GhcPs -> LHsType GhcPs -fromTyParen (L _ (HsParTy _ x)) = x -fromTyParen x = x - -isTyQuasiQuote :: LHsType GhcPs -> Bool -isTyQuasiQuote (L _ (HsSpliceTy _ HsQuasiQuote{})) = True -isTyQuasiQuote _ = False - -isUnboxedTuple :: HsTupleSort -> Bool -isUnboxedTuple HsUnboxedTuple = True -isUnboxedTuple _ = False diff --git a/src/Language/Haskell/GhclibParserEx/GHC/Hs/Types.hs b/src/Language/Haskell/GhclibParserEx/GHC/Hs/Types.hs deleted file mode 100644 --- a/src/Language/Haskell/GhclibParserEx/GHC/Hs/Types.hs +++ /dev/null @@ -1,9 +0,0 @@ --- Copyright (c) 2020, Shayne Fletcher. All rights reserved. --- SPDX-License-Identifier: BSD-3-Clause. - -module Language.Haskell.GhclibParserEx.GHC.Hs.Types - {-# DEPRECATED "Use Language.Haskell.GhclibParserEx.GHC.Hs.Type instead" #-} ( - module Language.Haskell.GhclibParserEx.GHC.Hs.Type - ) where - -import Language.Haskell.GhclibParserEx.GHC.Hs.Type diff --git a/src/Language/Haskell/GhclibParserEx/GHC/Parser.hs b/src/Language/Haskell/GhclibParserEx/GHC/Parser.hs deleted file mode 100644 --- a/src/Language/Haskell/GhclibParserEx/GHC/Parser.hs +++ /dev/null @@ -1,171 +0,0 @@ --- Copyright (c) 2020, Shayne Fletcher. All rights reserved. --- SPDX-License-Identifier: BSD-3-Clause. - -{-# LANGUAGE CPP #-} -#include "ghclib_api.h" -module Language.Haskell.GhclibParserEx.GHC.Parser( - parseFile - , parseModule - , parseSignature - , parseImport - , parseStatement - , parseBackpack - , parseDeclaration - , parseExpression - , parsePattern - , parseTypeSignature - , parseStmt - , parseIdentifier - , parseType - , parseHeader - , parse - ) - where - -#if defined (GHCLIB_API_HEAD) || defined (GHCLIB_API_904) || defined(GHCLIB_API_902) || defined (GHCLIB_API_900) || defined (GHCLIB_API_810) -import GHC.Hs -#else -import HsSyn -#endif -#if defined (GHCLIB_API_HEAD) || defined (GHCLIB_API_904) || defined(GHCLIB_API_902) -# if defined (GHCLIB_API_902) -import GHC.Driver.Config -# endif -# if defined (GHCLIB_API_HEAD) || defined (GHCLIB_API_904) -import GHC.Driver.Config.Parser -# endif -#endif -#if defined (GHCLIB_API_HEAD) || defined (GHCLIB_API_904) || defined(GHCLIB_API_902) || defined (GHCLIB_API_900) -import GHC.Parser.PostProcess -import GHC.Driver.Session -import GHC.Data.StringBuffer -import GHC.Parser.Lexer -import qualified GHC.Parser.Lexer as Lexer -import qualified GHC.Parser as Parser -import GHC.Data.FastString -import GHC.Types.SrcLoc -import GHC.Driver.Backpack.Syntax -import GHC.Unit.Info -import GHC.Types.Name.Reader -#else -import DynFlags -import StringBuffer -import Lexer -import qualified Parser -import FastString -import SrcLoc -import BkpSyn -import PackageConfig -import RdrName -#endif -#if defined (GHCLIB_API_810) -import RdrHsSyn -#endif - -parse :: P a -> String -> DynFlags -> ParseResult a -parse p str flags = - Lexer.unP p parseState - where - location = mkRealSrcLoc (mkFastString "") 1 1 - buffer = stringToStringBuffer str - parseState = -#if defined (GHCLIB_API_HEAD) || defined (GHCLIB_API_904) || defined(GHCLIB_API_902) - initParserState (initParserOpts flags) buffer location -#else - mkPState flags buffer location -#endif -#if defined (GHCLIB_API_904) || defined(GHCLIB_API_902) || defined (GHCLIB_API_900) -parseModule :: String -> DynFlags -> ParseResult (Located HsModule) -#else -parseModule :: String -> DynFlags -> ParseResult (Located (HsModule GhcPs)) -#endif -parseModule = parse Parser.parseModule - -#if defined (GHCLIB_API_904) || defined(GHCLIB_API_902) || defined (GHCLIB_API_900) -parseSignature :: String -> DynFlags -> ParseResult (Located HsModule) -#else -parseSignature :: String -> DynFlags -> ParseResult (Located (HsModule GhcPs)) -#endif -parseSignature = parse Parser.parseSignature - -parseImport :: String -> DynFlags -> ParseResult (LImportDecl GhcPs) -parseImport = parse Parser.parseImport - -parseStatement :: String -> DynFlags -> ParseResult (LStmt GhcPs (LHsExpr GhcPs)) -parseStatement = parse Parser.parseStatement - -parseBackpack :: String -> DynFlags -> ParseResult [LHsUnit PackageName] -parseBackpack = parse Parser.parseBackpack - -parseDeclaration :: String -> DynFlags -> ParseResult (LHsDecl GhcPs) -parseDeclaration = parse Parser.parseDeclaration - -parseExpression :: String -> DynFlags -> ParseResult (LHsExpr GhcPs) -#if defined (GHCLIB_API_HEAD) || defined (GHCLIB_API_904) || defined(GHCLIB_API_902) -parseExpression s flags = - -- The need for annotations here came about first manifested with - -- ghc-9.0.1 - case parse Parser.parseExpression s flags of - POk state e -> - let e' = e :: ECP - parser_validator = unECP e' :: PV (LHsExpr GhcPs) - parser = runPV parser_validator :: P (LHsExpr GhcPs) - in unP parser state :: ParseResult (LHsExpr GhcPs) - PFailed ps -> PFailed ps -#elif defined (GHCLIB_API_810) || defined (GHCLIB_API_900) -parseExpression s flags = - case parse Parser.parseExpression s flags of - POk s e -> unP (runECP_P e) s - PFailed ps -> PFailed ps -#else -parseExpression = parse Parser.parseExpression -#endif - -parsePattern :: String -> DynFlags -> ParseResult (LPat GhcPs) -parsePattern = parse Parser.parsePattern - -parseTypeSignature :: String -> DynFlags -> ParseResult (LHsDecl GhcPs) -parseTypeSignature = parse Parser.parseTypeSignature - -parseStmt :: String -> DynFlags -> ParseResult (Maybe (LStmt GhcPs (LHsExpr GhcPs))) -parseStmt = parse Parser.parseStmt - -#if defined (GHCLIB_API_HEAD) || defined (GHCLIB_API_904) || defined (GHCLIB_API_902) -parseIdentifier :: String -> DynFlags -> ParseResult (LocatedN RdrName) -#else -parseIdentifier :: String -> DynFlags -> ParseResult (Located RdrName) -#endif -parseIdentifier = parse Parser.parseIdentifier - -parseType :: String -> DynFlags -> ParseResult (LHsType GhcPs) -parseType = parse Parser.parseType - -#if defined (GHCLIB_API_904) || defined(GHCLIB_API_902) || defined (GHCLIB_API_900) -parseHeader :: String -> DynFlags -> ParseResult (Located HsModule) -#else -parseHeader :: String -> DynFlags -> ParseResult (Located (HsModule GhcPs)) -#endif -parseHeader = parse Parser.parseHeader - -#if defined (GHCLIB_API_904) || defined(GHCLIB_API_902) || defined (GHCLIB_API_900) -parseFile :: String - -> DynFlags - -> String - -> ParseResult (Located HsModule) -#else -parseFile :: String - -> DynFlags - -> String - -> ParseResult (Located (HsModule GhcPs)) -#endif -parseFile filename flags str = - unP Parser.parseModule parseState - where - location = mkRealSrcLoc (mkFastString filename) 1 1 - buffer = stringToStringBuffer str - parseState = -#if defined (GHCLIB_API_HEAD) || defined (GHCLIB_API_904) || defined(GHCLIB_API_902) - initParserState (initParserOpts flags) buffer location -#else - mkPState flags buffer location -#endif diff --git a/src/Language/Haskell/GhclibParserEx/GHC/Settings/Config.hs b/src/Language/Haskell/GhclibParserEx/GHC/Settings/Config.hs deleted file mode 100644 --- a/src/Language/Haskell/GhclibParserEx/GHC/Settings/Config.hs +++ /dev/null @@ -1,108 +0,0 @@ --- Copyright (c) 2020, Shayne Fletcher. All rights reserved. --- SPDX-License-Identifier: BSD-3-Clause. - -{-# OPTIONS_GHC -Wno-missing-fields #-} -{-# LANGUAGE CPP #-} -#include "ghclib_api.h" - -module Language.Haskell.GhclibParserEx.GHC.Settings.Config( - fakeSettings -#if !defined (GHCLIB_API_HEAD) - , fakeLlvmConfig -#endif - ) -where - -#if defined (GHCLIB_API_HEAD) || defined(GHCLIB_API_904) || defined(GHCLIB_API_902) || defined (GHCLIB_API_900) -import GHC.Settings.Config -import GHC.Driver.Session -import GHC.Utils.Fingerprint -import GHC.Platform -import GHC.Settings -#elif defined (GHCLIB_API_810) -import Config -import DynFlags -import Fingerprint -import GHC.Platform -import ToolSettings -#else -import Config -import DynFlags -import Fingerprint -import Platform -#endif - -fakeSettings :: Settings -fakeSettings = Settings -#if defined (GHCLIB_API_HEAD) || defined(GHCLIB_API_904) || defined(GHCLIB_API_902) || defined (GHCLIB_API_900)|| defined (GHCLIB_API_810) - { sGhcNameVersion=ghcNameVersion - , sFileSettings=fileSettings - , sTargetPlatform=platform - , sPlatformMisc=platformMisc -# if !defined(GHCLIB_API_HEAD) && !defined(GHCLIB_API_904) && !defined(GHCLIB_API_902) - , sPlatformConstants=platformConstants -# endif - , sToolSettings=toolSettings - } -#else - { sTargetPlatform=platform - , sPlatformConstants=platformConstants - , sProjectVersion=cProjectVersion - , sProgramName="ghc" - , sOpt_P_fingerprint=fingerprint0 - } -#endif - where -#if defined (GHCLIB_API_HEAD) || defined(GHCLIB_API_904) || defined(GHCLIB_API_902) || defined (GHCLIB_API_900)|| defined (GHCLIB_API_810) - toolSettings = ToolSettings { - toolSettings_opt_P_fingerprint=fingerprint0 - } - fileSettings = FileSettings {} - platformMisc = PlatformMisc {} - ghcNameVersion = - GhcNameVersion{ghcNameVersion_programName="ghc" - ,ghcNameVersion_projectVersion=cProjectVersion - } -#endif - platform = -#if defined (GHCLIB_API_HEAD) || defined(GHCLIB_API_904) || defined (GHCLIB_API_902) - genericPlatform -#else - Platform{ -# if defined (GHCLIB_API_900) - -- It doesn't matter what values we write here as these fields are - -- not referenced for our purposes. However the fields are strict - -- so we must say something. - platformByteOrder=LittleEndian - , platformHasGnuNonexecStack=True - , platformHasIdentDirective=False - , platformHasSubsectionsViaSymbols=False - , platformIsCrossCompiling=False - , platformLeadingUnderscore=False - , platformTablesNextToCode=False - , -# endif -# if defined (GHCLIB_API_810) || defined (GHCLIB_API_900) - platformWordSize=PW8 - , platformMini=PlatformMini {platformMini_arch=ArchUnknown, platformMini_os=OSUnknown} -# else - platformWordSize=8 - , platformOS=OSUnknown -# endif - , platformUnregisterised=True - } -#endif -#if !defined(GHCLIB_API_HEAD) && !defined(GHCLIB_API_904) && !defined(GHCLIB_API_902) - platformConstants = - PlatformConstants{pc_DYNAMIC_BY_DEFAULT=False,pc_WORD_SIZE=8} -#endif - -#if defined (GHCLIB_API_HEAD) --- Intentionally empty -#elif defined(GHCLIB_API_904) || defined(GHCLIB_API_902) || defined (GHCLIB_API_900)|| defined (GHCLIB_API_810) -fakeLlvmConfig :: LlvmConfig -fakeLlvmConfig = LlvmConfig [] [] -#else -fakeLlvmConfig :: (LlvmTargets, LlvmPasses) -fakeLlvmConfig = ([], []) -#endif diff --git a/src/Language/Haskell/GhclibParserEx/GHC/Types/Name/Reader.hs b/src/Language/Haskell/GhclibParserEx/GHC/Types/Name/Reader.hs deleted file mode 100644 --- a/src/Language/Haskell/GhclibParserEx/GHC/Types/Name/Reader.hs +++ /dev/null @@ -1,69 +0,0 @@ --- Copyright (c) 2020, Shayne Fletcher. All rights reserved. --- SPDX-License-Identifier: BSD-3-Clause. - -{-# LANGUAGE CPP #-} -#include "ghclib_api.h" - -module Language.Haskell.GhclibParserEx.GHC.Types.Name.Reader( - occNameStr, rdrNameStr, isSpecial, unqual, fromQual, isSymbolRdrName - ) -where - -#if defined (GHCLIB_API_HEAD) || defined(GHCLIB_API_904) || defined (GHCLIB_API_902) -import GHC.Parser.Annotation -#endif - -#if defined (GHCLIB_API_HEAD) || defined(GHCLIB_API_904) || defined(GHCLIB_API_902) || defined (GHCLIB_API_900) -import GHC.Types.SrcLoc -import GHC.Types.Name -import GHC.Types.Name.Reader -#else -import SrcLoc -import RdrName -import OccName -import Name -#endif - --- These names may not seem natural here but they work out in --- practice. The use of thse two functions is thoroughly ubiquitous. -occNameStr :: RdrName -> String; occNameStr = occNameString . rdrNameOcc -#if defined (GHCLIB_API_HEAD) || defined(GHCLIB_API_904) || defined (GHCLIB_API_902) -rdrNameStr :: GHC.Parser.Annotation.LocatedN RdrName -> String -#else -rdrNameStr :: Located RdrName -> String -#endif -rdrNameStr = occNameStr . unLoc - --- Builtin type or data constructors. -#if defined (GHCLIB_API_HEAD) || defined(GHCLIB_API_904) || defined (GHCLIB_API_902) -isSpecial :: LocatedN RdrName -> Bool -#else -isSpecial :: Located RdrName -> Bool -#endif -isSpecial (L _ (Exact n)) = isDataConName n || isTyConName n -isSpecial _ = False - --- Coerce qualified names to unqualified (by discarding the --- qualifier). -#if defined (GHCLIB_API_HEAD) || defined(GHCLIB_API_904) || defined (GHCLIB_API_902) -unqual :: LocatedN RdrName -> LocatedN RdrName -#else -unqual :: Located RdrName -> Located RdrName -#endif -unqual (L loc (Qual _ n)) = L loc $ mkRdrUnqual n -unqual x = x - --- Extract the occ name from a qualified/unqualified reader name. -#if defined (GHCLIB_API_HEAD) || defined(GHCLIB_API_904) || defined (GHCLIB_API_902) -fromQual :: LocatedN RdrName -> Maybe OccName -#else -fromQual :: Located RdrName -> Maybe OccName -#endif -fromQual (L _ (Qual _ x)) = Just x -fromQual (L _ (Unqual x)) = Just x -fromQual _ = Nothing - --- Test if the reader name is that of an operator (be it a data --- constructor, variable or whatever). -isSymbolRdrName :: RdrName -> Bool -isSymbolRdrName = isSymOcc . rdrNameOcc diff --git a/src/Language/Haskell/GhclibParserEx/GHC/Utils/Outputable.hs b/src/Language/Haskell/GhclibParserEx/GHC/Utils/Outputable.hs deleted file mode 100644 --- a/src/Language/Haskell/GhclibParserEx/GHC/Utils/Outputable.hs +++ /dev/null @@ -1,23 +0,0 @@ --- Copyright (c) 2020, Shayne Fletcher. All rights reserved. --- SPDX-License-Identifier: BSD-3-Clause. - -{-# LANGUAGE CPP #-} -#include "ghclib_api.h" -module Language.Haskell.GhclibParserEx.GHC.Utils.Outputable ( - unsafePrettyPrint -) -where - -#if defined (GHCLIB_API_HEAD) || defined (GHCLIB_API_904) || defined(GHCLIB_API_902) || defined (GHCLIB_API_900) -import GHC.Utils.Outputable -#else -import Outputable -#endif - -unsafePrettyPrint :: Outputable a => a -> String -unsafePrettyPrint = -#if defined (GHCLIB_API_HEAD) || defined (GHCLIB_API_904) - showPprUnsafe . ppr -#else - showSDocUnsafe . ppr -#endif diff --git a/src/Language/Haskell/GhclibParserEx/Outputable.hs b/src/Language/Haskell/GhclibParserEx/Outputable.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/GhclibParserEx/Outputable.hs @@ -0,0 +1,9 @@ +-- Copyright (c) 2020, Shayne Fletcher. All rights reserved. +-- SPDX-License-Identifier: BSD-3-Clause. + +module Language.Haskell.GhclibParserEx.Outputable (unsafePrettyPrint) where + +import Outputable + +unsafePrettyPrint :: (Outputable.Outputable a) => a -> String +unsafePrettyPrint = Outputable.showSDocUnsafe . Outputable.ppr diff --git a/src/Language/Haskell/GhclibParserEx/Parse.hs b/src/Language/Haskell/GhclibParserEx/Parse.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/GhclibParserEx/Parse.hs @@ -0,0 +1,149 @@ +-- Copyright (c) 2020, Shayne Fletcher. All rights reserved. +-- SPDX-License-Identifier: BSD-3-Clause. + +{-# OPTIONS_GHC -Wno-missing-fields #-} +{-# LANGUAGE CPP #-} +#include "ghclib_api.h" + +module Language.Haskell.GhclibParserEx.Parse( + parse + , parseExpr + , parseImport + , parseDeclaration + , parseFile + , parsePragmasIntoDynFlags + , fakeSettings + , fakeLlvmConfig + ) + where + +#if defined (GHCLIB_API_811) || defined (GHCLIB_API_810) +import GHC.Hs +import RdrHsSyn +#else +import HsSyn +#endif +import Config +import DynFlags +import StringBuffer +import Fingerprint +import Lexer +import qualified Parser +import FastString +import SrcLoc +import Panic +import HscTypes +import HeaderInfo + +#if defined (GHCLIB_API_811) || defined (GHCLIB_API_810) +import GHC.Platform +import ToolSettings +#else +import Platform +#endif + +fakeSettings :: Settings +fakeSettings = Settings +#if defined (GHCLIB_API_811) || defined (GHCLIB_API_810) + { sGhcNameVersion=ghcNameVersion + , sFileSettings=fileSettings + , sTargetPlatform=platform + , sPlatformMisc=platformMisc + , sPlatformConstants=platformConstants + , sToolSettings=toolSettings + } +#else + { sTargetPlatform=platform + , sPlatformConstants=platformConstants + , sProjectVersion=cProjectVersion + , sProgramName="ghc" + , sOpt_P_fingerprint=fingerprint0 + } +#endif + where +#if defined (GHCLIB_API_811) || defined (GHCLIB_API_810) + toolSettings = ToolSettings { + toolSettings_opt_P_fingerprint=fingerprint0 + } + fileSettings = FileSettings {} + platformMisc = PlatformMisc {} + ghcNameVersion = + GhcNameVersion{ghcNameVersion_programName="ghc" + ,ghcNameVersion_projectVersion=cProjectVersion + } +#endif + platform = + Platform{ +#if defined (GHCLIB_API_811) || defined (GHCLIB_API_810) + platformWordSize = PW8 + , platformMini = PlatformMini {platformMini_arch=ArchUnknown, platformMini_os=OSUnknown} +#else + platformWordSize=8 + , platformOS=OSUnknown +#endif + , platformUnregisterised=True + } + platformConstants = + PlatformConstants{pc_DYNAMIC_BY_DEFAULT=False,pc_WORD_SIZE=8} + +#if defined (GHCLIB_API_811) || defined (GHCLIB_API_810) +fakeLlvmConfig :: LlvmConfig +fakeLlvmConfig = LlvmConfig [] [] +#else +fakeLlvmConfig :: (LlvmTargets, LlvmPasses) +fakeLlvmConfig = ([], []) +#endif + +parse :: P a -> String -> DynFlags -> ParseResult a +parse p str flags = + Lexer.unP p parseState + where + location = mkRealSrcLoc (mkFastString "") 1 1 + buffer = stringToStringBuffer str + parseState = mkPState flags buffer location + +#if defined (GHCLIB_API_811) +parseExpr :: String -> DynFlags -> ParseResult RdrHsSyn.ECP +#else +parseExpr :: String -> DynFlags -> ParseResult (LHsExpr GhcPs) +#endif +parseExpr = parse Parser.parseExpression + +parseImport :: String -> DynFlags -> ParseResult (LImportDecl GhcPs) +parseImport = parse Parser.parseImport + +parseDeclaration :: String -> DynFlags -> ParseResult (LHsDecl GhcPs) +parseDeclaration = parse Parser.parseDeclaration + +#if defined (GHC_API_811) +parseFile :: String + -> DynFlags + -> String + -> ParseResult (Located HsModule) +#else +parseFile :: String + -> DynFlags + -> String + -> ParseResult (Located (HsModule GhcPs)) +#endif +parseFile filename flags str = + unP Parser.parseModule parseState + where + location = mkRealSrcLoc (mkFastString filename) 1 1 + buffer = stringToStringBuffer str + parseState = mkPState flags buffer location + +parsePragmasIntoDynFlags :: DynFlags + -> FilePath + -> String + -> IO (Either String DynFlags) +parsePragmasIntoDynFlags flags file str = + catchErrors $ do + let opts = getOptions flags (stringToStringBuffer str) file + (flags, _, _) <- parseDynamicFilePragma flags opts + return $ Right (flags `gopt_set` Opt_KeepRawTokenStream) + where + catchErrors :: IO (Either String DynFlags) -> IO (Either String DynFlags) + catchErrors act = handleGhcException reportErr + (handleSourceError reportErr act) + reportErr e = return $ Left (show e) diff --git a/test/Test.hs b/test/Test.hs --- a/test/Test.hs +++ b/test/Test.hs @@ -3,156 +3,50 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE LambdaCase #-} -{-# LANGUAGE TypeApplications #-} #include "ghclib_api.h" import Test.Tasty import Test.Tasty.HUnit -import System.FilePath import System.Directory as Directory import System.Environment import qualified System.FilePath as FilePath import System.IO.Extra import Control.Monad -import Data.List.Extra -import Data.Maybe -import Data.Generics.Uniplate.Data -#if defined (GHCLIB_API_HEAD) || defined (GHCLIB_API_904) || defined (GHCLIB_API_902) -import GHC.Data.Bag -#if !defined (GHCLIB_API_902) -import GHC.Driver.Errors.Types -#endif -import GHC.Types.Error -#endif +import Language.Haskell.GhclibParserEx.Parse import Language.Haskell.GhclibParserEx.Dump import Language.Haskell.GhclibParserEx.Fixity -import Language.Haskell.GhclibParserEx.GHC.Settings.Config -import Language.Haskell.GhclibParserEx.GHC.Parser -import Language.Haskell.GhclibParserEx.GHC.Hs -import Language.Haskell.GhclibParserEx.GHC.Hs.ExtendInstances -import Language.Haskell.GhclibParserEx.GHC.Hs.Expr -import Language.Haskell.GhclibParserEx.GHC.Hs.Pat -import Language.Haskell.GhclibParserEx.GHC.Hs.Type --- We only test 'isImportQualifiedPost' at this time which requires >= --- 8.10; avoid unused import warning. -#if defined (MIN_VERSION_ghc_lib_parser) -# if !MIN_VERSION_ghc_lib_parser(1, 0, 0) || MIN_VERSION_ghc_lib_parser(8, 10, 0) -import Language.Haskell.GhclibParserEx.GHC.Hs.ImpExp -# endif -#elif __GLASGOW_HASKELL__ >= 810 -import Language.Haskell.GhclibParserEx.GHC.Hs.ImpExp -#endif -import Language.Haskell.GhclibParserEx.GHC.Driver.Flags() -import Language.Haskell.GhclibParserEx.GHC.Driver.Session -import Language.Haskell.GhclibParserEx.GHC.Types.Name.Reader -#if defined (GHCLIB_API_HEAD) || defined (GHCLIB_API_904) || defined (GHCLIB_API_902) || defined (GHCLIB_API_900) || defined (GHCLIB_API_810) +#if defined (GHCLIB_API_811) || defined (GHCLIB_API_810) import GHC.Hs #else import HsSyn #endif -#if defined (GHCLIB_API_HEAD) || defined (GHCLIB_API_904) || defined (GHCLIB_API_902) || defined (GHCLIB_API_900) -import GHC.Types.SrcLoc -import GHC.Driver.Session -import GHC.Parser.Lexer -# if !defined (GHCLIB_API_HEAD) -import GHC.Utils.Outputable -#endif -# if !defined (GHCLIB_API_900) -import GHC.Driver.Ppr -# if !defined (GHCLIB_API_HEAD) && !defined (GHCLIB_API_904) -import GHC.Parser.Errors.Ppr -# endif -# endif -import GHC.Utils.Error -import GHC.Types.Name.Reader -import GHC.Types.Name.Occurrence -#else -import SrcLoc import DynFlags import Lexer import Outputable import ErrUtils -import RdrName -import OccName -#endif -import GHC.LanguageExtensions.Type +import RdrHsSyn #if defined (GHCLIB_API_808) import Bag #endif -basicDynFlags :: DynFlags -basicDynFlags = - defaultDynFlags fakeSettings -#if !defined (GHCLIB_API_HEAD) - fakeLlvmConfig -#endif - main :: IO () main = do setEnv "TASTY_NUM_THREADS" "1" - setUnsafeGlobalDynFlags basicDynFlags + setUnsafeGlobalDynFlags (defaultDynFlags fakeSettings fakeLlvmConfig) defaultMain tests tests :: TestTree -tests = testGroup " All tests" - [ parseTests - , fixityTests - , extendInstancesTests - , expressionPredicateTests - , typePredicateTests - , patternPredicateTests - , dynFlagsTests - , nameTests - ] - -makeFile :: FilePath -> String -> IO FilePath -makeFile relPath contents = do - Directory.createDirectoryIfMissing True $ FilePath.takeDirectory relPath - writeFile relPath contents - return relPath - -#if defined(GHCLIB_API_HEAD) -report :: DynFlags -> Bag (MsgEnvelope GhcMessage) -> String -report flags msgs = concat [ showSDoc flags msg | msg <- pprMsgEnvelopeBagWithLocDefault msgs ] -#elif defined (GHCLIB_API_904) -report :: DynFlags -> Bag (MsgEnvelope GhcMessage) -> String -report flags msgs = concat [ showSDoc flags msg | msg <- pprMsgEnvelopeBagWithLoc msgs ] -#elif defined (GHCLIB_API_902) -report :: DynFlags -> Bag (MsgEnvelope DecoratedSDoc) -> String -report flags msgs = concat [ showSDoc flags msg | msg <- pprMsgEnvelopeBagWithLoc msgs ] -#else -report :: DynFlags -> WarningMessages -> String -report flags msgs = concat [ showSDoc flags msg | msg <- pprErrMsgBagWithLoc msgs ] -#endif +tests = testGroup " All tests" [parseTests, fixityTests] -chkParseResult :: DynFlags -> ParseResult a -> IO () -chkParseResult flags = \case +chkParseResult :: (DynFlags -> WarningMessages -> String) -> DynFlags -> ParseResult a -> IO () +chkParseResult report flags = \case POk s _ -> do -#if defined (GHCLIB_API_HEAD) || defined (GHCLIB_API_904) - let (wrns, errs) = getPsMessages s -#elif defined (GHCLIB_API_902) - let (wrns, errs) = getMessages s -#else let (wrns, errs) = getMessages s flags -#endif when (not (null errs) || not (null wrns)) $ -#if defined (GHCLIB_API_HEAD) || defined (GHCLIB_API_904) - assertFailure ( - report flags (getMessages (GhcPsMessage <$> wrns)) ++ - report flags (getMessages (GhcPsMessage <$> errs)) - ) -#elif defined (GHCLIB_API_902) - assertFailure (report flags (fmap pprWarning wrns) ++ report flags (fmap pprError errs)) -#else assertFailure (report flags wrns ++ report flags errs) -#endif -#if defined (GHCLIB_API_HEAD) || defined (GHCLIB_API_904) - PFailed s -> assertFailure (report flags $ getMessages (GhcPsMessage <$> snd (getPsMessages s))) -#elif defined (GHCLIB_API_902) - PFailed s -> assertFailure (report flags $ fmap pprError (snd (getMessages s))) -#elif defined (GHCLIB_API_900) || defined (GHCLIB_API_810) +#if defined (GHCLIB_API_811) || defined (GHCLIB_API_810) PFailed s -> assertFailure (report flags $ snd (getMessages s flags)) #else PFailed _ loc err -> assertFailure (report flags $ unitBag $ mkPlainErrMsg flags loc err) @@ -161,335 +55,68 @@ parseTests :: TestTree parseTests = testGroup "Parse tests" [ - testCase "Module" $ - chkParseResult flags ( - parseModule (unlines - [ "module Foo (readMany) where" - , "import Data.List" - , "import Data.Maybe" - , "readMany = unfoldr $ listToMaybe . concatMap reads . tails" - ]) flags) - , testCase "Module" $ - chkParseResult flags ( - parseModule (unlines - [ "module Foo (readMany) where" - , "import Data.List" - , "import Data.Maybe" - , "readMany = unfoldr $ listToMaybe . concatMap reads . tails" - ]) flags) - , testCase "Signature" $ - chkParseResult flags ( - parseSignature (unlines - [ "signature Str where" - , "data Str" - , "empty :: Str" - , "append :: Str -> Str -> Str" - ]) flags) - , testCase "Import" $ - chkParseResult flags ( - parseImport "import qualified \"foo-lib\" Foo as Bar hiding ((<.>))" flags) - , testCase "Statement" $ - chkParseResult flags ( - parseStatement "Foo foo <- bar" flags) - , testCase "Backpack" $ - chkParseResult flags ( - parseBackpack (unlines - [ "unit main where" - , " module Main where" - , " main = putStrLn \"Hello world!\"" - ]) flags) - , testCase "Expression" $ - chkParseResult flags ( - parseExpression "unfoldr $ listToMaybe . concatMap reads . tails" flags) - , testCase "Declaration (1)" $ - chkParseResult flags ( - parseDeclaration "fact n = if n <= 1 then 1 else n * fact (n - 1)" flags) - , testCase "Declaration (2)" $ -- Example from https://github.com/ndmitchell/hlint/issues/842. - chkParseResult flags ( - parseDeclaration "infixr 4 <%@~" flags) - , testCase "File" $ withTempDir $ \tmpDir -> do - foo <- makeFile (tmpDir "Foo.hs") $ unlines - ["{-# LANGUAGE ScopedTypeVariables #-}" - , "module Foo (readMany) where" + testCase "Expression" $ do + let flags = defaultDynFlags fakeSettings fakeLlvmConfig + chkParseResult report flags $ + parseExpr "unfoldr $ listToMaybe . concatMap reads . tails" flags + , testCase "Import" $ do + let flags = defaultDynFlags fakeSettings fakeLlvmConfig + chkParseResult report flags $ + parseImport "import qualified \"foo-lib\" Foo as Bar hiding ((<.>))" flags + , testCase "Declaration" $ do + let flags = defaultDynFlags fakeSettings fakeLlvmConfig + chkParseResult report flags $ + parseDeclaration ( + unlines [ + "fact :: Int -> Int" + , "fact n = if n <= 1 then 1 else n * fact (n - 1)" + ]) flags + , testCase "File" $ do + foo <- makeFile "Foo.hs" $ unlines + [ "module Foo (readMany) where" , "import Data.List" , "import Data.Maybe" , "readMany = unfoldr $ listToMaybe . concatMap reads . tails" ] s <- readFile' foo - parsePragmasIntoDynFlags flags ([], []) foo s >>= \case + parsePragmasIntoDynFlags (defaultDynFlags fakeSettings fakeLlvmConfig) foo s >>= \case Left msg -> assertFailure msg - Right flags -> chkParseResult flags (parseFile foo flags s) + Right flags -> + chkParseResult report flags $ parseFile foo (flags `gopt_set` Opt_KeepRawTokenStream) s ] where - flags = basicDynFlags - -#if defined (GHCLIB_API_904) || defined (GHCLIB_API_902) || defined (GHCLIB_API_900) -moduleTest :: String -> DynFlags -> (Located HsModule -> IO ()) -> IO () -#else -moduleTest :: String -> DynFlags -> (Located (HsModule GhcPs) -> IO ()) -> IO () -#endif -moduleTest s flags test = - case parseModule s flags of - POk _ e -> test e - _ -> assertFailure "parse error" - -exprTest :: String -> DynFlags -> (LHsExpr GhcPs -> IO ()) -> IO () -exprTest s flags test = - case parseExpression s flags of - POk _ e -> test e - _ -> assertFailure "parse error" - -typeTest :: String -> DynFlags -> (LHsType GhcPs -> IO ()) -> IO () -typeTest s flags test = - case parseType s flags of - POk _ e -> test e - _ -> assertFailure "parse error" - -patTest :: String -> DynFlags -> (LPat GhcPs -> IO ()) -> IO () -patTest s flags test = - case parsePattern s flags of - POk _ e -> test e - _ -> assertFailure "parse error" + report flags msgs = concat [ showSDoc flags msg | msg <- pprErrMsgBagWithLoc msgs ] fixityTests :: TestTree fixityTests = testGroup "Fixity tests" - [ testCase "Expression" $ - exprTest "1 + 2 * 3" flags - (\e -> - assertBool "parse tree not affected" $ -#if defined (GHCLIB_API_HEAD) || defined (GHCLIB_API_904) || defined (GHCLIB_API_902) - showSDocUnsafe (showAstData BlankSrcSpan BlankEpAnnotations e) /= - showSDocUnsafe (showAstData BlankSrcSpan BlankEpAnnotations (applyFixities [] e)) -#else - showSDocUnsafe (showAstData BlankSrcSpan e) /= - showSDocUnsafe (showAstData BlankSrcSpan (applyFixities [] e)) + [ + testCase "Expression" $ do + let flags = defaultDynFlags fakeSettings fakeLlvmConfig + case parseExpr "1 + 2 * 3" flags of + POk s e -> +#if defined (GHCLIB_API_811) || defined (GHCLIB_API_810) + case unP (runECP_P e >>= \e -> return e) s :: ParseResult (LHsExpr GhcPs) of + POk _ e -> #endif - ) - , testCase "Pattern" $ + assertBool "parse tree not affected" $ + showSDocUnsafe (showAstData BlankSrcSpan e) /= + showSDocUnsafe (showAstData BlankSrcSpan (applyFixities [] e)) +#if defined (GHCLIB_API_811) || defined (GHCLIB_API_810) + PFailed{} -> assertFailure "ecp failure" +#endif + PFailed{} -> assertFailure "parse error" + , testCase "Pattern" $ do + let flags = defaultDynFlags fakeSettings fakeLlvmConfig case parseDeclaration "f (1 : 2 :[]) = 1" flags of POk _ d -> assertBool "parse tree not affected" $ -#if defined (GHCLIB_API_HEAD) || defined (GHCLIB_API_904) || defined (GHCLIB_API_902) - showSDocUnsafe (showAstData BlankSrcSpan BlankEpAnnotations d) /= - showSDocUnsafe (showAstData BlankSrcSpan BlankEpAnnotations (applyFixities [] d)) -#else showSDocUnsafe (showAstData BlankSrcSpan d) /= showSDocUnsafe (showAstData BlankSrcSpan (applyFixities [] d)) -#endif PFailed{} -> assertFailure "parse error" - , testCase "fixitiesFromModule" $ - case parseModule "infixl 4 <*!" flags of - POk _ m -> - assertBool "one fixity expected" $ not (null (fixitiesFromModule m)) - PFailed{} -> assertFailure "parse error" ] - where - flags = basicDynFlags -extendInstancesTests :: TestTree -extendInstancesTests = testGroup "Extend instances tests" - [ testCase "Eq, Ord" $ - exprTest "1 + 2 * 3" flags - (\e -> do - e' <- return $ applyFixities [] e - assertBool "astEq" $ astEq e e - assertBool "astEq" $ not (astEq e e') - e <- return $ extendInstances e - e' <- return $ extendInstances e' - assertBool "==" $ e == e - assertBool "/=" $ e /= e' - assertBool "< " $ e' < e - assertBool ">=" $ e >= e' - ) - ] - where - flags = basicDynFlags - -typePredicateTests :: TestTree -typePredicateTests = testGroup "Type predicate tests" - [ testCase "isKindTyApp" $ test_with_exts [TypeApplications] "K @T" $ assert' . isKindTyApp - , testCase "isKindTyApp" $ test_with_exts [TypeApplications] "K T" $ assert' . not . isKindTyApp - ] - where - assert' = assertBool "" - test_with_exts exts s = typeTest s (flags exts) - flags = foldl' xopt_set basicDynFlags - -expressionPredicateTests :: TestTree -expressionPredicateTests = testGroup "Expression predicate tests" - [ testCase "isTag" $ test "foo" $ assert' . isTag "foo" - , testCase "isTag" $ test "bar" $ assert' . not . isTag "foo" - , testCase "isDol" $ test "f $ x" $ \case L _ (OpApp _ _ op _) -> assert' $ isDol op; _ -> assertFailure "unexpected" - , testCase "isDot" $ test "f . g" $ \case L _ (OpApp _ _ op _) -> assert' $ isDot op; _ -> assertFailure "unexpected" - , testCase "isReturn" $ test "return x" $ \case L _ (HsApp _ f _) -> assert' $ isReturn f; _ -> assertFailure "unexpected" - , testCase "isReturn" $ test "pure x" $ \case L _ (HsApp _ f _) -> assert' $ isReturn f; _ -> assertFailure "unexpected" -#if defined (GHCLIB_API_HEAD) || defined (GHCLIB_API_904) - , testCase "isSection" $ test "(1 +)" $ \case L _ (HsPar _ _ x _) -> assert' $ isSection x; _ -> assertFailure "unexpected" -#else - , testCase "isSection" $ test "(1 +)" $ \case L _ (HsPar _ x) -> assert' $ isSection x; _ -> assertFailure "unexpected" -#endif -#if defined (GHCLIB_API_HEAD) || defined (GHCLIB_API_904) - , testCase "isSection" $ test "(+ 1)" $ \case L _ (HsPar _ _ x _) -> assert' $ isSection x; _ -> assertFailure "unexpected" -#else - , testCase "isSection" $ test "(+ 1)" $ \case L _ (HsPar _ x) -> assert' $ isSection x; _ -> assertFailure "unexpected" -#endif - , testCase "isRecConstr" $ test "Foo {bar=1}" $ assert' . isRecConstr - , testCase "isRecUpdate" $ test "foo {bar=1}" $ assert' . isRecUpdate - , testCase "isVar" $ test "foo" $ assert' . isVar - , testCase "isVar" $ test "3" $ assert' . not. isVar - , testCase "isPar" $ test "(foo)" $ assert' . isPar - , testCase "isPar" $ test "foo" $ assert' . not . isPar - , testCase "isApp" $ test "f x" $ assert' . isApp - , testCase "isApp" $ test "x" $ assert' . not . isApp - , testCase "isOpApp" $ test "l `op` r" $ assert' . isOpApp - , testCase "isOpApp" $ test "op l r" $ assert' . not . isOpApp - , testCase "isAnyApp" $ test "l `op` r" $ assert' . isAnyApp - , testCase "isAnyApp" $ test "f x" $ assert' . isAnyApp - , testCase "isAnyApp" $ test "f x y" $ assert' . isAnyApp - , testCase "isAnyApp" $ test "(f x y)" $ assert' . not . isAnyApp - , testCase "isLexeme" $ test "foo" $ assert' . isLexeme - , testCase "isLexeme" $ test "3" $ assert' . isLexeme - , testCase "isLexeme" $ test "f x" $ assert' . not . isLexeme - , testCase "isLambda" $ test "\\x -> 12" $ assert' . isLambda - , testCase "isLambda" $ test "foo" $ assert' . not . isLambda - , testCase "isDotApp" $ test "f . g" $ assert' . isDotApp - , testCase "isDotApp" $ test "f $ g" $ assert' . not . isDotApp - , testCase "isTypeApp" $ test "f @Int" $ assert' . isTypeApp -#if defined (GHCLIB_API_808) || defined (GHCLIB_API_810) - , testCase "isTypeApp" $ test "f @ Int" $ assert' . isTypeApp -#else - , testCase "isTypeApp" $ test "f @ Int" $ assert' . not . isTypeApp -#endif - , testCase "isTypeApp" $ test "f" $ assert' . not . isTypeApp - , testCase "isWHNF" $ test "[]" $ assert' . isWHNF - , testCase "isWHNF" $ test "[1, 2]" $ assert' . isWHNF - , testCase "isWHNF" $ test "'f'" $ assert' . isWHNF - , testCase "isWHNF" $ test "foo" $ assert' . not . isWHNF - , testCase "isWHNF" $ test "42" $ assert' . not . isWHNF - , testCase "isWHNF" $ test "\\foo -> []" $ assert' . isWHNF - , testCase "isWHNF" $ test "(\\foo -> [])" $ assert' . isWHNF - , testCase "isWHNF" $ test "(\\foo -> []) x" $ assert' . not . isWHNF - , testCase "isWHNF" $ test "(42, \"foo\")" $ assert' . isWHNF - , testCase "isWHNF" $ test "(42, \"foo\") :: (Int, String)" $ assert' . isWHNF - , testCase "isWHNF" $ test "(\\x -> x * x) 3 :: Int" $ assert' . not . isWHNF - , testCase "isWHNF" $ test "Just foo" $ assert' . isWHNF - , testCase "isWHNF" $ test "Left foo" $ assert' . isWHNF - , testCase "isWHNF" $ test "Right foo" $ assert' . isWHNF - , testCase "isWHNF" $ test "POk s" $ assert' . not . isWHNF - , testCase "isLCase" $ test "\\case _ -> False" $ assert' . isLCase - , testCase "isLCase" $ test "case x of _ -> False" $ assert' . not . isLCase - , testCase "isSpliceDecl" $ test "$x" $ assert' . isSpliceDecl . unLoc - , testCase "isSpliceDecl" $ test "f$x" $ assert' . not . isSpliceDecl . unLoc - , testCase "isSpliceDecl" $ test "$(a + b)" $ assert' . isSpliceDecl . unLoc - , testCase "isQuasiQuoteExpr" $ test "[expr|1 + 2|]" $ assert' . isQuasiQuoteExpr - , testCase "isQuasiQuoteExpr" $ test "[expr(1 + 2)]" $ assert' . not . isQuasiQuoteExpr - , testCase "isWholeFrac" $ test "3.2e1" $ assert' . isWholeFrac . unLoc - , testCase "isWholeFrac" $ test "3.22e1" $ assert' . not . isWholeFrac . unLoc - , testCase "isMDo" $ test_with_exts [ RecursiveDo ] "mdo { pure () }" $ assert' . any isMDo . universeBi - , testCase "isListComp (1)" $ test "[ x + y | x <- xs, y <- ys ]" $ assert' . any isListComp . universeBi - , testCase "isListComp (2)" $ test_with_exts [ MonadComprehensions ] "[ x + y | x <- xs, y <- ys ]" $ assert' . any isMonadComp . universeBi - , testCase "isMonadComp (0)" $ test_with_exts [ MonadComprehensions ] "[ x + y | x <- Just 1, y <- Just 2 ]" $ assert' . not . any isListComp . universeBi - , testCase "isMonadComp (1)" $ test_with_exts [ MonadComprehensions ] "[ x + y | x <- Just 1, y <- Just 2 ]" $ assert' . any isMonadComp . universeBi - , testCase "isMonadComp (2)" $ test_with_exts [] "[ x + y | x <- Just 1, y <- Just 2 ]" $ assert' . not . any isMonadComp . universeBi - , testCase "isMonadComp (3)" $ test_with_exts [] "[ x + y | x <- Just 1, y <- Just 2 ]" $ assert' . any isListComp . universeBi - , testCase "strToVar" $ assert' . isVar . strToVar $ "foo" - , testCase "varToStr" $ test "[]" $ assert' . (== "[]") . varToStr - , testCase "varToStr" $ test "foo" $ assert' . (== "foo") . varToStr - , testCase "varToStr" $ test "3" $ assert' . null . varToStr - ] - where - assert' = assertBool "" - test s = exprTest s (flags []) - test_with_exts exts s = exprTest s (flags exts) - flags exts = foldl' xopt_set basicDynFlags - (exts ++ - [ TemplateHaskell - , TemplateHaskellQuotes - , QuasiQuotes - , TypeApplications - , LambdaCase - ] - ) - -patternPredicateTests :: TestTree -patternPredicateTests = testGroup "Pattern predicate tests" - [ testCase "patToStr" $ test "True" $ assert' . (== "True") . patToStr - , testCase "patToStr" $ test "False" $ assert' . (== "False") . patToStr - , testCase "patToStr" $ test "[]" $ assert' . (== "[]") . patToStr - , testCase "strToPat" $ assert' . (== "True") . patToStr . strToPat $ "True" - , testCase "strToPat" $ assert' . (== "False") . patToStr . strToPat $ "False" - , testCase "strToPat" $ assert' . (== "[]") . patToStr . strToPat $ "[]" - , testCase "fromPChar" $ test "'a'" $ assert' . (== Just 'a') . fromPChar - , testCase "fromPChar" $ test "\"a\"" $ assert' . isNothing . fromPChar - , testCase "isSplicePat" $ test "$(varP pylonExPtrVarName)" $ assert' . isSplicePat - ] - where - assert' = assertBool "" - test = test_with_exts [] - test_with_exts exts s = patTest s (flags exts) - flags exts = foldl' xopt_set basicDynFlags - (exts ++ - [ TemplateHaskell - , TemplateHaskellQuotes - , QuasiQuotes - , TypeApplications - , LambdaCase - ] - ) - -dynFlagsTests :: TestTree -dynFlagsTests = testGroup "DynFlags tests" - [ testCase "readExtension" $ assertBool "parse DeriveTraversable" (readExtension "DeriveTraversable" == Just DeriveTraversable) - , testCase "readExtension" $ assertBool "parse DeriveTravresable" (isNothing $ readExtension "DeriveTravresable") - , testCase "extensionImplications" $ do - Just (_, (es, ds)) <- return $ find (\(e, _) -> e == DeriveTraversable) extensionImplications - assertBool "no extensions disabled" (null ds) - assertBool "two extensions enabled" $ DeriveFunctor `elem` es && DeriveFoldable `elem` es - , testCase "check instance Bounded Language" $ assertBool "enumerate is null" (not (null (enumerate @Language))) - , testCase "check instance Ord Extension" $ assertBool "minBound >= maxBound" (minBound @Extension < maxBound @Extension) - , testCase "disable via pragma" $ withTempDir $ \tmpDir -> do - foo <- makeFile (tmpDir "Foo.hs") $ unlines - [ "{-# LANGUAGE NoStarIsType #-}" - , "{-# LANGUAGE ExplicitNamespaces #-}" - , "import GHC.TypeLits(KnownNat, type (+), type (*))" - ] - s <- readFile' foo - -- If 'StarIsType' ends up enabled after - -- 'parsePragmasIntoDynflags' has done its work, we'll get a - -- parse error (see - -- https://github.com/ndmitchell/hlint/issues/971). - parsePragmasIntoDynFlags flags ([StarIsType], []) foo s >>= \case - Left msg -> assertFailure msg - Right flags -> chkParseResult flags (parseFile foo flags s) -#if defined (MIN_VERSION_ghc_lib_parser) -# if !MIN_VERSION_ghc_lib_parser(1, 0, 0) || MIN_VERSION_ghc_lib_parser(8, 10, 0) - , testCase "ImportQualifiedPost" $ do - case parseImport "import Foo qualified" (flags `xopt_set` ImportQualifiedPost) of - POk _ (L _ decl) -> assertBool "expected postpositive" (isImportQualifiedPost . ideclQualified $ decl) - PFailed _ -> assertFailure "parse error" -# endif -#elif __GLASGOW_HASKELL__ >= 810 - , testCase "ImportQualifiedPost" $ do - case parseImport "import Foo qualified" (flags `xopt_set` ImportQualifiedPost) of - POk _ (L _ decl) -> assertBool "expected postpositive" (isImportQualifiedPost . ideclQualified $ decl) - PFailed _ -> assertFailure "parse error" -#endif - ] - where - flags = basicDynFlags - -nameTests :: TestTree -nameTests = testGroup "Name tests" - [ testCase "modName (1)" $ - moduleTest "module Foo.Bar.Baz where" flags - (\n -> assertBool "Unexpected name string" $ modName n == "Foo.Bar.Baz") - , testCase "modName (2)" $ - moduleTest "f x = x * 2" flags - (\n -> assertBool "Unexpected name string" $ modName n == "Main") - , testCase "isSymbolRdrName (1)" $ assertBool "Expected 'True'" $ isSymbolRdrName (mkRdrUnqual (mkVarOcc "+")) - , testCase "isSymbolRdrName (2)" $ assertBool "Expected 'False'" $ not (isSymbolRdrName (mkRdrUnqual (mkVarOcc "_foo"))) - , testCase "isSymbolRdrName (3)" $ assertBool "Expected 'False'" $ not (isSymbolRdrName (mkRdrUnqual (mkVarOcc "foo'"))) - , testCase "isSymbolRdrName (4)" $ assertBool "Expected 'True'" $ isSymbolRdrName (mkRdrUnqual (mkVarOcc ":+:")) - ] - where - flags = basicDynFlags +makeFile :: FilePath -> String -> IO FilePath +makeFile relPath contents = do + Directory.createDirectoryIfMissing True $ FilePath.takeDirectory relPath + writeFile relPath contents + return relPath