ghc-lib-parser-ex-9.12.0.0/0000755000000000000000000000000007346545000013343 5ustar0000000000000000ghc-lib-parser-ex-9.12.0.0/CI.hs0000644000000000000000000001200207346545000014165 0ustar0000000000000000-- Copyright (c) 2020, 2024 Shayne Fletcher. All rights reserved. -- SPDX-License-Identifier: BSD-3-Clause. {-# LANGUAGE CPP #-} {-# LANGUAGE NamedFieldPuns #-} import Control.Monad.Extra #if __GLASGOW_HASKELL__ < 906 import Control.Applicative (liftA2) #endif import Data.Bifunctor import Data.List.Extra import Data.Time.Calendar import Data.Time.Clock import qualified Options.Applicative as Opts import System.Exit import System.IO.Extra import System.Process.Extra main :: IO () main = do let opts = Opts.info (parseOptions Opts.<**> Opts.helper) ( Opts.fullDesc <> Opts.progDesc "Build and test ghc-lib-parser-ex." <> Opts.header "CI - CI script for ghc-lib-parser-ex" ) options <- Opts.execParser opts buildTestDist options buildTestDist :: Options -> IO () buildTestDist Options {versionTag = userGivenTag, noBuilds} = do assignVersionPatchCabal userGivenTag system_ "cabal sdist -o ." when noBuilds exitSuccess system_ "cabal build lib:ghc-lib-parser-ex --ghc-options=-j" system_ "cabal test test:ghc-lib-parser-ex-test --ghc-options=-j --test-show-details=direct --test-options=\"--color always\"" #if __GLASGOW_HASKELL__ == 808 && \ (__GLASGOW_HASKELL_PATCHLEVEL1__ == 1 || __GLASGOW_HASKELL_PATCHLEVEL1__ == 2) && \ defined (mingw32_HOST_OS) -- https://gitlab.haskell.org/ghc/ghc/issues/17599 #else system_ "cabal exec -- ghc -ignore-dot-ghci -package=ghc-lib-parser-ex -e \"print 1\"" #endif assignVersionPatchCabal :: Maybe String -> IO () assignVersionPatchCabal userTag = do version <- mkVersion userTag patchCabal version contents <- readFile' "ghc-lib-parser-ex.cabal" putStrLn contents hFlush stdout where mkVersion :: Maybe String -> IO String mkVersion = maybe (do UTCTime day _ <- getCurrentTime; pure $ genVersionStr day) pure genVersionStr :: Day -> String genVersionStr day = "0." ++ replace "-" "" (showGregorian day) patchCabal :: String -> IO () patchCabal version = do putStrLn "Patching cabal:" putStrLn $ "- version " ++ version writeFile "ghc-lib-parser-ex.cabal" . replace "version: 0.1.0" ("version: " ++ version) =<< readFile' "ghc-lib-parser-ex.cabal" let series | Just (major, Just (minor, _)) <- second (stripInfix ".") <$> stripInfix "." version = liftA2 (,) (maybeRead major) (maybeRead minor) | otherwise = Nothing case series of Just (major, minor) -> do let (lower, upper, family) = bounds (major, minor) putStrLn $ "- ghc >= " ++ lower ++ " && ghc < " ++ upper putStrLn $ "- ghc-lib-parser " ++ family writeFile "ghc-lib-parser-ex.cabal" . replace "9.0.0" lower . replace "9.1.0" upper . replace "9.0.*" family =<< readFile' "ghc-lib-parser-ex.cabal" Nothing -> do let ghcLibParserVersion = version putStrLn $ "- ghc-lib-parser " ++ ghcLibParserVersion writeFile "ghc-lib-parser-ex.cabal" . replace buildDependsSection ( unlines [ " build-depends:", " ghc-lib-parser == " ++ ghcLibParserVersion, " -- pseduo use of flags to suppress cabal check warnings", " if flag(auto)", " if flag(no-ghc-lib)" ] ) =<< readFile' "ghc-lib-parser-ex.cabal" where maybeRead :: String -> Maybe Int maybeRead s | [(x, "")] <- reads s = Just x | otherwise = Nothing buildDependsSection :: String buildDependsSection = unlines [ " if flag(auto) && impl(ghc >= 9.0.0) && impl(ghc < 9.1.0)", " build-depends:", " ghc == 9.0.*,", " ghc-boot-th,", " ghc-boot", " else", " if flag(auto)", " build-depends:", " ghc-lib-parser == 9.0.*", " else", " if flag(no-ghc-lib)", " build-depends:", " ghc == 9.0.*,", " ghc-boot-th,", " ghc-boot", " else", " build-depends:", " ghc-lib-parser == 9.0.*" ] bounds :: (Int, Int) -> (String, String, String) bounds (major, minor) = let lower = if lower' == "9.2.0" then "9.2.2" else lower' upper = upper' family = family' in (lower, upper, family) where lower' = show major ++ "." ++ show minor ++ ".0" upper' = show major ++ "." ++ show (minor + 1) ++ ".0" family' = show major ++ "." ++ show minor ++ ".*" data Options = Options { versionTag :: Maybe String, -- If 'Just _' use this as the version (e.g. "8.8.1.20191204") noBuilds :: Bool -- Don't build or run tests } deriving (Show) parseOptions :: Opts.Parser Options parseOptions = Options <$> Opts.optional ( Opts.strOption (Opts.long "version-tag" <> Opts.help "Set version") ) <*> Opts.switch (Opts.long "no-builds" <> Opts.help "If enabled, stop after producing sdists") ghc-lib-parser-ex-9.12.0.0/ChangeLog.md0000644000000000000000000002424707346545000015525 0ustar0000000000000000# Changelog for ghc-lib-parser-ex # 9.12.0.0 released - Add support for ghc-9.12 series: `GHCLIB_API_912` ## 9.10.0.0 released - Deprecate `Dump` - New module `GHC.Hs.Dump` - Add support for ghc-9.10 series: `GHCLIB_API_910` ## 9.8.0.2 released - Fix broken cpp in `isStrictMatch` ## 9.8.0.1 released - New functions `isWildPat` ## 9.8.0.0 released - Companion to `ghc-lib-parser-9.8.1.20231009` ## 9.6.0.2 released - New functions `isTypedSplice`, `isUntypedSpice` ## 9.6.0.1 released - Add `&` to `baseFixities` - Add support for ghc-9.8 series: `GH_9_8` - New functions `isLetStmt` and `isDo` ## 9.6.0.0 released - Add support for ghc-9.6 series: `GHC_9_6` ## 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 ghc-lib-parser-ex-9.12.0.0/LICENSE0000644000000000000000000000311607346545000014351 0ustar0000000000000000Copyright Shayne Fletcher 2020. * BSD-3-Clause license (https://opensource.org/licenses/BSD-3-Clause) BSD 3-Clause License All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. * Neither the name of Neil Mitchell nor the names of other contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ghc-lib-parser-ex-9.12.0.0/README.md0000644000000000000000000000560107346545000014624 0ustar0000000000000000# 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) [![ghc-lib-parser-ex-ghc-lib-parser-9.10.1.20240511](https://github.com/shayne-fletcher/ghc-lib-parser-ex/actions/workflows/ghc-lib-parser-ex-ghc-lib-parser-9.10.1.20240511.yml/badge.svg)](https://github.com/shayne-fletcher/ghc-lib-parser-ex/actions/workflows/ghc-lib-parser-ex-ghc-lib-parser-9.10.1.20240511.yml) Copyright © 2020-2024 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 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. ## Building `ghc-lib-parser-ex` Produce and test `ghc-lib-parser-ex` package distributions by executing the CI script: ```bash git clone git@github.com:shayne-fletcher/ghc-lib-parser-ex.git cd ghc-lib-parser-ex cabal run exe:ghc-lib-parser-ex-build-tool --allow-newer="ghc-lib-parser-ex:ghc-lib-parser" --constraint="ghc-lib-parser == 9.10.1.20240511" -- --version-tag 9.10.0.1 ``` To run [`hlint`](https://github.com/ndmitchell/hlint) on this repository, `hlint --cpp-include cbits --cpp-define GHC_XXXX .` (where `XXXX` at this time is one of `8_8`, `8_10`, `9_0`, `9_2`, `9_4`, `9_6`, `9_8` or `9_10`). ## Releasing `ghc-lib-parser-ex` (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). ghc-lib-parser-ex-9.12.0.0/Setup.hs0000644000000000000000000000005607346545000015000 0ustar0000000000000000import Distribution.Simple main = defaultMain ghc-lib-parser-ex-9.12.0.0/cbits/0000755000000000000000000000000007346545000014447 5ustar0000000000000000ghc-lib-parser-ex-9.12.0.0/cbits/ghclib_api.h0000644000000000000000000000403707346545000016705 0ustar0000000000000000/* Copyright (c) 2020 - 2024 Shayne Fletcher. All rights reserved. SPDX-License-Identifier: BSD-3-Clause. */ #if !defined(GHCLIB_API_H) # define GHCLIB_API_H # if !(defined (GHC_9_14) \ || defined (GHC_9_12) \ || defined (GHC_9_10) \ || defined (GHC_9_8) \ || defined (GHC_9_6) \ || defined (GHC_9_4) \ || defined (GHC_9_2) \ || defined (GHC_9_0) \ || defined (GHC_8_10) \ || defined (GHC_8_8)) # if defined (MIN_VERSION_ghc_lib_parser) # if !MIN_VERSION_ghc_lib_parser ( 1, 0, 0) # define GHC_9_14 # elif MIN_VERSION_ghc_lib_parser (9, 12, 0) # define GHC_9_12 # elif MIN_VERSION_ghc_lib_parser (9, 10, 0) # define GHC_9_10 # elif MIN_VERSION_ghc_lib_parser (9, 8, 0) # define GHC_9_8 # elif MIN_VERSION_ghc_lib_parser (9, 6, 0) # define GHC_9_6 # elif MIN_VERSION_ghc_lib_parser (9, 4, 0) # define GHC_9_4 # elif MIN_VERSION_ghc_lib_parser (9, 2, 0) # define GHC_9_2 # elif MIN_VERSION_ghc_lib_parser (9, 0, 0) # define GHC_9_0 # elif MIN_VERSION_ghc_lib_parser (8, 10, 0) # define GHC_8_10 # elif MIN_VERSION_ghc_lib_parser (8, 8, 0) # define GHC_8_8 # else # error Unsupported GHC API version # endif # else # if __GLASGOW_HASKELL__ == 914 # define GHC_9_14 # elif __GLASGOW_HASKELL__ == 912 # define GHC_9_12 # elif __GLASGOW_HASKELL__ == 910 # define GHC_9_10 # elif __GLASGOW_HASKELL__ == 908 # define GHC_9_8 # elif __GLASGOW_HASKELL__ == 906 # define GHC_9_6 # elif __GLASGOW_HASKELL__ == 904 # define GHC_9_4 # elif __GLASGOW_HASKELL__ == 902 # define GHC_9_2 # elif __GLASGOW_HASKELL__ == 900 # define GHC_9_0 # elif __GLASGOW_HASKELL__ == 810 # define GHC_8_10 # elif __GLASGOW_HASKELL__ == 808 # define GHC_8_8 # else # error Unsupported GHC API version # endif # endif # endif #endif ghc-lib-parser-ex-9.12.0.0/ghc-lib-parser-ex.cabal0000644000000000000000000000642007346545000017542 0ustar0000000000000000cabal-version: 3.4 name: ghc-lib-parser-ex version: 9.12.0.0 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-2024 Shayne Fletcher. All rights reserved. license: BSD-3-Clause license-file: LICENSE category: Development synopsis: Programming with GHC parse trees build-type: Simple extra-source-files: README.md ChangeLog.md 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 default: False manual: True description: Do not link ghc-lib. Use the native GHC libs common base default-language: Haskell2010 ghc-options: -Wall -Wincomplete-record-updates -Wredundant-constraints -Widentities -Wunused-imports -Wno-name-shadowing build-depends: base >=4.7 && <5 common ghc_libs include-dirs: cbits default-extensions: CPP if flag(auto) && impl(ghc >= 9.12.0) && impl(ghc < 9.13.0) build-depends: ghc == 9.12.*, ghc-boot-th, ghc-boot else if flag(auto) build-depends: ghc-lib-parser == 9.12.* else if flag(no-ghc-lib) build-depends: ghc == 9.12.*, ghc-boot-th, ghc-boot else build-depends: ghc-lib-parser == 9.12.* common lib import: base, ghc_libs build-depends: uniplate >= 1.5, bytestring >= 0.10.8.2, containers >= 0.5.8.1 library import: lib exposed-modules: 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.Dump 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 autogen-modules: Paths_ghc_lib_parser_ex other-modules: Paths_ghc_lib_parser_ex hs-source-dirs: src common test import: lib build-depends: tasty >= 1.2, tasty-hunit >= 0.10.0, directory >= 1.3.1, filepath >= 1.4.2, extra >=1.6, uniplate >= 1.6.12, ghc-lib-parser-ex test-suite ghc-lib-parser-ex-test import: test type: exitcode-stdio-1.0 ghc-options: -threaded -rtsopts -with-rtsopts=-N main-is: Test.hs hs-source-dirs: test executable ghc-lib-parser-ex-build-tool import: base build-depends: directory, filepath, time, extra, optparse-applicative main-is: CI.hs ghc-lib-parser-ex-9.12.0.0/src/Language/Haskell/GhclibParserEx/0000755000000000000000000000000007346545000022102 5ustar0000000000000000ghc-lib-parser-ex-9.12.0.0/src/Language/Haskell/GhclibParserEx/Dump.hs0000644000000000000000000000053107346545000023342 0ustar0000000000000000-- Copyright (c) 2024, Shayne Fletcher. All rights reserved. -- SPDX-License-Identifier: BSD-3-Clause. module Language.Haskell.GhclibParserEx.Dump {-# DEPRECATED "Use Language.Haskell.GhclibParserEx.GHC.Hs.Dump instead" #-} ( module Language.Haskell.GhclibParserEx.GHC.Hs.Dump, ) where import Language.Haskell.GhclibParserEx.GHC.Hs.Dump ghc-lib-parser-ex-9.12.0.0/src/Language/Haskell/GhclibParserEx/Fixity.hs0000644000000000000000000003021307346545000023711 0ustar0000000000000000-- Copyright (c) 2020-2024, Shayne Fletcher. All rights reserved. -- SPDX-License-Identifier: BSD-3-Clause. -- -- Adapted from (1) https://github.com/mpickering/apply-refact.git and -- (2) https://gitlab.haskell.org/ghc/ghc ('compiler/renamer/RnTypes.hs'). {- ORMOLU_DISABLE -} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE TupleSections #-} #include "ghclib_api.h" module Language.Haskell.GhclibParserEx.Fixity( applyFixities , fixitiesFromModule , preludeFixities, baseFixities , infixr_, infixl_, infix_, fixity ) where #if defined (GHC_8_8) import BasicTypes import HsSyn import OccName import RdrName import SrcLoc #elif defined (GHC_8_10) import BasicTypes import GHC.Hs import OccName import RdrName import SrcLoc #elif defined (GHC_9_0) import GHC.Hs import GHC.Types.Basic import GHC.Types.Name import GHC.Types.Name.Reader import GHC.Types.SrcLoc #elif defined (GHC_9_2) || defined (GHC_9_4) || defined (GHC_9_6) import GHC.Hs import GHC.Types.Fixity import GHC.Types.Name import GHC.Types.Name.Reader import GHC.Types.SourceText import GHC.Types.SrcLoc #elif defined (GHC_9_8) || defined (GHC_9_10) import GHC.Data.FastString import GHC.Hs import GHC.Types.Fixity import GHC.Types.Name import GHC.Types.Name.Reader import GHC.Types.SourceText import GHC.Types.SrcLoc #else import GHC.Hs import GHC.Types.Fixity import GHC.Types.Name.Reader import GHC.Types.Name import GHC.Types.SrcLoc #endif import Data.Data hiding (Fixity) import Data.Maybe import Data.Generics.Uniplate.Data #if defined (GHC_9_0) || defined (GHC_8_10) noExt :: NoExtField noExt = noExtField #endif -- | Rearrange a parse tree to account for fixities. applyFixities :: Data a => [(String, Fixity)] -> a -> a applyFixities fixities m = let m' = transformBi (expFix fixities) m m'' = transformBi (patFix fixities) m' in m'' expFix :: [(String, Fixity)] -> LHsExpr GhcPs -> LHsExpr GhcPs expFix fixities (L loc (OpApp _ l op r)) = mkOpApp (getFixities fixities) loc l op (findFixity (getFixities fixities) op) r expFix _ e = e -- 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 (GHC_8_10) || defined (GHC_8_8) ) patFix fixities (L loc (ConPat _ op (InfixCon pat1 pat2))) = L loc (mkConOpPat (getFixities fixities) op (findFixity' (getFixities fixities) op) pat1 pat2) #elif defined (GHC_8_10) patFix fixities (L loc (ConPatIn op (InfixCon pat1 pat2))) = L loc (mkConOpPat (getFixities fixities) op (findFixity' (getFixities fixities) op) pat1 pat2) #else patFix fixities (dL -> L _ (ConPatIn op (InfixCon pat1 pat2))) = mkConOpPat (getFixities fixities) op (findFixity' (getFixities fixities) op) pat1 pat2 #endif patFix _ p = p mkConOpPat :: [(String, Fixity)] #if ! (defined (GHC_9_0) || defined (GHC_8_10) || defined (GHC_8_8)) -> LocatedN RdrName #else -> Located RdrName #endif -> Fixity -> LPat GhcPs -> LPat GhcPs -> Pat GhcPs #if ! ( defined (GHC_8_10) || defined (GHC_8_8) ) mkConOpPat fs op2 fix2 p1@(L loc (ConPat _ op1 (InfixCon p11 p12))) p2 #elif defined (GHC_8_10) 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 (GHC_9_0) || defined (GHC_8_10) || defined (GHC_8_8)) | nofix_error = ConPat noAnn op2 (InfixCon p1 p2) #elif defined (GHC_9_0) | nofix_error = ConPat noExtField op2 (InfixCon p1 p2) #else | nofix_error = ConPatIn op2 (InfixCon p1 p2) #endif #if ! (defined (GHC_9_0) || defined (GHC_8_10) || defined (GHC_8_8)) | associate_right = ConPat noAnn op1 (InfixCon p11 (L loc (mkConOpPat fs op2 fix2 p12 p2))) #elif defined (GHC_9_0) | associate_right = ConPat noExtField op1 (InfixCon p11 (L loc (mkConOpPat fs op2 fix2 p12 p2))) #elif defined (GHC_8_10) | 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))) #endif #if ! (defined (GHC_9_0) || defined (GHC_8_10) || defined (GHC_8_8)) | otherwise = ConPat noAnn op2 (InfixCon p1 p2) #elif defined (GHC_9_0) | 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 (GHC_9_0) || defined (GHC_8_10) || defined (GHC_8_8)) mkConOpPat _ op _ p1 p2 = ConPat noAnn op (InfixCon p1 p2) #elif defined (GHC_9_0) 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 (GHC_9_0) || defined (GHC_8_10) || defined (GHC_8_8)) -> 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 -- (e11 `op1` e12) `op2` e2 mkOpApp fs loc e1@(L _ (OpApp x1 e11 op1 e12)) op2 fix2 e2 # if ! ( defined (GHC_9_10) || defined (GHC_9_8) || defined (GHC_9_6) || defined (GHC_9_4) || defined (GHC_9_2) || defined (GHC_9_0) || defined (GHC_8_10) || defined (GHC_8_8) ) -- ghc > 9.10 | nofix_error = L loc (OpApp noExtField e1 op2 e2) #elif ! (defined (GHC_9_0) || defined (GHC_8_10) || defined (GHC_8_8)) -- ghc > 9.0 | nofix_error = L loc (OpApp noAnn e1 op2 e2) #else -- otherwise | 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 (GHC_9_0) || defined (GHC_8_10) || defined (GHC_8_8)) 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 (GHC_9_10) || defined (GHC_9_8) || defined (GHC_9_6) || defined (GHC_9_4) || defined (GHC_9_2) || defined (GHC_9_0) || defined (GHC_8_10) || defined (GHC_8_8) ) -- ghc > 9.10 | nofix_error = L loc (OpApp noExtField e1 op2 e2) #elif ! (defined (GHC_9_0) || defined (GHC_8_10) || defined (GHC_8_8)) -- ghc > 9.0 | nofix_error = L loc (OpApp noAnn e1 op2 e2) #else -- otherwise | nofix_error = L loc (OpApp noExt e1 op2 e2) #endif #if ! (defined (GHC_9_0) || defined (GHC_8_10) || defined (GHC_8_8)) | 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 (GHC_9_0) || defined (GHC_8_10) || defined (GHC_8_8)) 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 (GHC_9_10) || defined (GHC_9_8) || defined (GHC_9_6) || defined (GHC_9_4) || defined (GHC_9_2) || defined (GHC_9_0) || defined (GHC_8_10) || defined (GHC_8_8) ) -- ghc > 9.10 | not associate_right = L loc (OpApp noExtField e1 op1 e2)-- We *want* right association. #elif ! (defined (GHC_9_0) || defined (GHC_8_10) || defined (GHC_8_8)) | 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 (GHC_9_10) || defined (GHC_9_8) || defined (GHC_9_6) || defined (GHC_9_4) || defined (GHC_9_2) || defined (GHC_9_0) || defined (GHC_8_10) || defined (GHC_8_8) ) -- ghc > 9.10 mkOpApp _ loc e1 op _fix e2 = L loc (OpApp noExtField e1 op e2) #elif ! (defined (GHC_9_0) || defined (GHC_8_10) || defined (GHC_8_8)) 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'. 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 (GHC_9_0) || defined (GHC_8_10) || defined (GHC_8_8)) 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 askFix xs = \k -> lookupWithDefault defaultFixity k xs where lookupWithDefault def_v k mp1 = fromMaybe def_v $ lookup k mp1 -- All fixities defined in the Prelude. preludeFixities :: [(String, Fixity)] preludeFixities = concat [ infixr_ 9 ["."] , infixl_ 9 ["!!"] , infixr_ 8 ["^","^^","**"] , infixl_ 7 ["*","/","quot","rem","div","mod",":%","%"] , infixl_ 6 ["+","-"] , infixr_ 5 [":","++"] , infix_ 4 ["==","/=","<","<=",">=",">","elem","notElem"] , infixr_ 3 ["&&"] , infixr_ 2 ["||"] , infixl_ 1 [">>",">>="] , infixr_ 1 ["=<<"] , infixr_ 0 ["$","$!","seq"] ] -- All fixities defined in the base package. Note that the @+++@ -- operator appears in both Control.Arrows and -- Text.ParserCombinators.ReadP. The listed precedence for @+++@ in -- this list is that of Control.Arrows. baseFixities :: [(String, Fixity)] baseFixities = preludeFixities ++ concat [ infixr_ 9 ["Compose"] , 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. , infix_ 5 ["\\\\"] , infixl_ 4 ["<$>","<$","$>","<*>","<*","*>","<**>","<$!>"] , infix_ 4 ["elemP","notElemP",":~:", ":~~:"] , infixl_ 3 ["<|>"] , infixr_ 3 ["&&&","***"] , infixr_ 2 ["+++","|||"] , infixl_ 1 ["&"] , infixr_ 1 ["<=<",">=>",">>>","<<<","^<<","<<^","^>>",">>^"] , infixl_ 0 ["on"] , infixr_ 0 ["par","pseq"] ] infixr_, infixl_, infix_ :: Int -> [String] -> [(String,Fixity)] infixr_ = fixity InfixR infixl_ = fixity InfixL infix_ = fixity InfixN fixity :: FixityDirection -> Int -> [String] -> [(String, Fixity)] # if ! (defined (GHC_9_10) || defined (GHC_9_8) || defined (GHC_9_6) || defined (GHC_9_4) || defined (GHC_9_2) || defined (GHC_9_0) || defined (GHC_8_10) || defined (GHC_8_8) ) fixity a p = map (,Fixity p a) #elif ! (defined (GHC_9_6) || defined (GHC_9_4) || defined (GHC_9_2) || defined (GHC_9_0) || defined (GHC_8_10) || defined (GHC_8_8) ) fixity a p = map (,Fixity (SourceText (fsLit "")) p a) #else fixity a p = map (,Fixity (SourceText "") p a) #endif #if defined (GHC_9_4) || defined(GHC_9_2) || defined (GHC_9_0) fixitiesFromModule :: Located HsModule -> [(String, Fixity)] #else fixitiesFromModule :: Located (HsModule GhcPs) -> [(String, Fixity)] #endif #if ! (defined (GHC_9_4) || defined (GHC_9_2) || defined (GHC_9_0) || defined (GHC_8_10) || defined (GHC_8_8)) fixitiesFromModule (L _ (HsModule _ _ _ _ decls)) = concatMap f decls #elif defined (GHC_9_4) || defined(GHC_9_2) fixitiesFromModule (L _ (HsModule _ _ _ _ _ decls _ _)) = concatMap f decls #elif defined (GHC_9_0) fixitiesFromModule (L _ (HsModule _ _ _ _ decls _ _)) = concatMap f decls #else fixitiesFromModule (L _ (HsModule _ _ _ decls _ _)) = concatMap f decls #endif where f :: LHsDecl GhcPs -> [(String, Fixity)] # if ! (defined (GHC_9_10) || defined (GHC_9_8) || defined (GHC_9_6) || defined (GHC_9_4) || defined (GHC_9_2) || defined (GHC_9_0) || defined (GHC_8_10) || defined (GHC_8_8) ) f (L _ (SigD _ (FixSig _ (FixitySig _ ops (Fixity p dir))))) = #else f (L _ (SigD _ (FixSig _ (FixitySig _ ops (Fixity _ p dir))))) = #endif fixity dir p (map (occNameString. rdrNameOcc . unLoc) ops) f _ = [] ghc-lib-parser-ex-9.12.0.0/src/Language/Haskell/GhclibParserEx/GHC/Driver/0000755000000000000000000000000007346545000023736 5ustar0000000000000000ghc-lib-parser-ex-9.12.0.0/src/Language/Haskell/GhclibParserEx/GHC/Driver/Flags.hs0000644000000000000000000000072107346545000025326 0ustar0000000000000000-- Copyright (c) 2020-2023, Shayne Fletcher. All rights reserved. -- SPDX-License-Identifier: BSD-3-Clause. {-# OPTIONS_GHC -Wno-orphans #-} #include "ghclib_api.h" module Language.Haskell.GhclibParserEx.GHC.Driver.Flags () where #if defined (GHC_8_10) || defined (GHC_8_8) import DynFlags -- This instance landed in -- https://gitlab.haskell.org/ghc/ghc/merge_requests/2905. instance Bounded Language where minBound = Haskell98 maxBound = Haskell2010 #endif ghc-lib-parser-ex-9.12.0.0/src/Language/Haskell/GhclibParserEx/GHC/Driver/Session.hs0000644000000000000000000002121107346545000025712 0ustar0000000000000000-- Copyright (c) 2020-2023, Shayne Fletcher. All rights reserved. -- SPDX-License-Identifier: BSD-3-Clause. {- ORMOLU_DISABLE -} #include "ghclib_api.h" {-# OPTIONS_GHC -Wno-orphans #-} module Language.Haskell.GhclibParserEx.GHC.Driver.Session( readExtension , extensionImplications -- Landed in https://gitlab.haskell.org/ghc/ghc/merge_requests/2654. #if defined (GHC_8_8) || defined (GHC_8_10) , TurnOnFlag, turnOn, turnOff, impliedGFlags, impliedOffGFlags, impliedXFlags #endif , parsePragmasIntoDynFlags ) where #if defined (GHC_8_8) import qualified GHC.LanguageExtensions as LangExt import Panic import HeaderInfo import StringBuffer import DynFlags import HscTypes #elif defined (GHC_8_10) import qualified GHC.LanguageExtensions as LangExt import Panic import HeaderInfo import StringBuffer import DynFlags import HscTypes #elif defined (GHC_9_0) import GHC.Utils.Panic import GHC.Parser.Header import GHC.Data.StringBuffer import GHC.Driver.Session import GHC.Driver.Types #else import GHC.Utils.Panic import GHC.Parser.Header import GHC.Data.StringBuffer import GHC.Driver.Session import GHC.Types.SourceError #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 (GHC_8_8) || defined (GHC_8_10) import Data.Function -- For `compareOn`. instance Ord Extension where compare = compare `on` fromEnum #endif #if ! (defined (GHC_9_2) || defined (GHC_9_0) || defined (GHC_8_10) || defined(GHC_8_8) ) import GHC.Driver.Config.Parser #endif -- | Parse a GHC extension. readExtension :: String -> Maybe Extension readExtension s = flagSpecFlag <$> find (\(FlagSpec n _ _ _) -> n == s) xFlags #if (defined (GHC_9_12) || defined (GHC_9_10) || defined (GHC_9_8) || defined (GHC_9_6) || defined (GHC_9_4) || defined (GHC_9_2) || defined (GHC_9_0) || defined (GHC_8_10) || defined(GHC_8_8) ) -- | 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 ] #else {- defined (GHC_9_14) -} -- | 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, ([strip c | b], [strip c | not b])) | (a, c) <- impliedXFlags, let b = case c of On _ -> True; Off _ -> False ] strip :: OnOff a -> a strip (On e) = e strip (Off e) = e #endif -- Landed in -- https://gitlab.haskell.org/ghc/ghc/merge_requests/2654. Copied from -- 'ghc/compiler/main/DynFlags.hs'. #if defined(GHC_8_8) || defined(GHC_8_10) 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(GHC_8_10) -- 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 (GHC_9_2) || defined (GHC_9_0) || defined (GHC_8_10) || defined (GHC_8_8)) let opts = getOptions flags (stringToStringBuffer str) file #elif (defined (GHC_9_12) || defined (GHC_9_10) || defined (GHC_9_8) || defined (GHC_9_6) || defined (GHC_9_4)) let (_, opts) = getOptions (initParserOpts flags) (stringToStringBuffer str) file #else let (_, opts) = getOptions (initParserOpts flags) (supportedLanguagePragmas 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) ghc-lib-parser-ex-9.12.0.0/src/Language/Haskell/GhclibParserEx/GHC/0000755000000000000000000000000007346545000022503 5ustar0000000000000000ghc-lib-parser-ex-9.12.0.0/src/Language/Haskell/GhclibParserEx/GHC/Hs.hs0000644000000000000000000000143607346545000023415 0ustar0000000000000000-- Copyright (c) 2020-2023, Shayne Fletcher. All rights reserved. -- SPDX-License-Identifier: BSD-3-Clause. #include "ghclib_api.h" module Language.Haskell.GhclibParserEx.GHC.Hs ( modName, ) where #if defined (GHC_8_8) import HsSyn import Module import SrcLoc #elif defined (GHC_8_10) import GHC.Hs import Module import SrcLoc #elif defined (GHC_9_0) || defined (GHC_9_2) || defined (GHC_9_4) import GHC.Hs import GHC.Unit.Module import GHC.Types.SrcLoc #else import GHC.Hs import GHC.Types.SrcLoc #endif #if defined (GHC_9_4) || defined (GHC_9_2) || defined (GHC_9_0) 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 ghc-lib-parser-ex-9.12.0.0/src/Language/Haskell/GhclibParserEx/GHC/Hs/0000755000000000000000000000000007346545000023055 5ustar0000000000000000ghc-lib-parser-ex-9.12.0.0/src/Language/Haskell/GhclibParserEx/GHC/Hs/Binds.hs0000644000000000000000000000064607346545000024456 0ustar0000000000000000-- Copyright (c) 2020-2023, Shayne Fletcher. All rights reserved. -- SPDX-License-Identifier: BSD-3-Clause. #include "ghclib_api.h" module Language.Haskell.GhclibParserEx.GHC.Hs.Binds ( isPatSynBind, ) where #if defined (GHC_8_8) import HsBinds import HsExtension #else import GHC.Hs.Binds import GHC.Hs.Extension #endif isPatSynBind :: HsBind GhcPs -> Bool isPatSynBind PatSynBind {} = True isPatSynBind _ = False ghc-lib-parser-ex-9.12.0.0/src/Language/Haskell/GhclibParserEx/GHC/Hs/Decls.hs0000644000000000000000000000133707346545000024447 0ustar0000000000000000-- Copyright (c) 2020-2023, Shayne Fletcher. All rights reserved. -- SPDX-License-Identifier: BSD-3-Clause. #include "ghclib_api.h" module Language.Haskell.GhclibParserEx.GHC.Hs.Decls ( isNewType, isForD, isDerivD, isClsDefSig, ) where #if defined(GHC_8_8) import HsSyn #else import GHC.Hs #endif #if defined (GHC_8_10) || defined (GHC_8_8) import SrcLoc #else import GHC.Types.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 ghc-lib-parser-ex-9.12.0.0/src/Language/Haskell/GhclibParserEx/GHC/Hs/Dump.hs0000644000000000000000000001775707346545000024337 0ustar0000000000000000-- Copyright (c) 2020-2023, Shayne Fletcher. All rights reserved. -- SPDX-License-Identifier: BSD-3-Clause. {- (c) The University of Glasgow 2006 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -} {- ORMOLU_DISABLE -} {- HLINT ignore -} -- Not our code. {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} #include "ghclib_api.h" module Language.Haskell.GhclibParserEx.GHC.Hs.Dump( showAstData , BlankSrcSpan(..) #if ! (defined (GHC_9_0) || defined (GHC_8_10) || defined (GHC_8_8) ) , BlankEpAnnotations(..) #endif ) where #if !defined(MIN_VERSION_ghc_lib_parser) -- Pay attenion: This is the native GHC case. # if defined (GHC_8_8) import HsDumpAst # else import GHC.Hs.Dump # endif #else -- Once again, attenion please. This is the ghc-lib-parser case. # if !defined (GHC_8_8) import GHC.Hs.Dump # else -- In the 8.8 case reproduce the implementation (the original ended up -- in ghc-lib). import Prelude as X hiding ((<>)) import Data.Data hiding (Fixity) import Bag import BasicTypes import FastString import NameSet import Name import DataCon import SrcLoc import HsSyn import OccName hiding (occName) import Var import Module import Outputable import qualified Data.ByteString as B data BlankSrcSpan = BlankSrcSpan | NoBlankSrcSpan deriving (Eq,Show) -- | Show a GHC syntax tree. This parameterised because it is also used for -- comparing ASTs in ppr roundtripping tests, where the SrcSpan's are blanked -- out, to avoid comparing locations, only structure showAstData :: Data a => BlankSrcSpan -> a -> SDoc showAstData b a0 = blankLine $$ showAstData' a0 where showAstData' :: Data a => a -> SDoc showAstData' = generic `ext1Q` list `extQ` string `extQ` fastString `extQ` srcSpan `extQ` lit `extQ` litr `extQ` litt `extQ` bytestring `extQ` name `extQ` occName `extQ` moduleName `extQ` var `extQ` dataCon `extQ` bagName `extQ` bagRdrName `extQ` bagVar `extQ` nameSet `extQ` fixity `ext2Q` located where generic :: Data a => a -> SDoc generic t = parens $ text (showConstr (toConstr t)) $$ vcat (gmapQ showAstData' t) string :: String -> SDoc string = text . normalize_newlines . show fastString :: FastString -> SDoc fastString s = braces $ text "FastString: " <> text (normalize_newlines . show $ s) bytestring :: B.ByteString -> SDoc bytestring = text . normalize_newlines . show list [] = brackets empty list [x] = brackets (showAstData' x) list (x1 : x2 : xs) = (text "[" <> showAstData' x1) $$ go x2 xs where go y [] = text "," <> showAstData' y <> text "]" go y1 (y2 : ys) = (text "," <> showAstData' y1) $$ go y2 ys -- Eliminate word-size dependence lit :: HsLit GhcPs -> SDoc lit (HsWordPrim s x) = numericLit "HsWord{64}Prim" x s lit (HsWord64Prim s x) = numericLit "HsWord{64}Prim" x s lit (HsIntPrim s x) = numericLit "HsInt{64}Prim" x s lit (HsInt64Prim s x) = numericLit "HsInt{64}Prim" x s lit l = generic l litr :: HsLit GhcRn -> SDoc litr (HsWordPrim s x) = numericLit "HsWord{64}Prim" x s litr (HsWord64Prim s x) = numericLit "HsWord{64}Prim" x s litr (HsIntPrim s x) = numericLit "HsInt{64}Prim" x s litr (HsInt64Prim s x) = numericLit "HsInt{64}Prim" x s litr l = generic l litt :: HsLit GhcTc -> SDoc litt (HsWordPrim s x) = numericLit "HsWord{64}Prim" x s litt (HsWord64Prim s x) = numericLit "HsWord{64}Prim" x s litt (HsIntPrim s x) = numericLit "HsInt{64}Prim" x s litt (HsInt64Prim s x) = numericLit "HsInt{64}Prim" x s litt l = generic l numericLit :: String -> Integer -> SourceText -> SDoc numericLit tag x s = braces $ hsep [ text tag , generic x , generic s ] name :: Name -> SDoc name nm = braces $ text "Name: " <> ppr nm occName n = braces $ text "OccName: " <> text (OccName.occNameString n) moduleName :: ModuleName -> SDoc moduleName m = braces $ text "ModuleName: " <> ppr m srcSpan :: SrcSpan -> SDoc srcSpan ss = case b of BlankSrcSpan -> text "{ ss }" NoBlankSrcSpan -> braces $ char ' ' <> (hang (ppr ss) 1 -- TODO: show annotations here (text "")) var :: Var -> SDoc var v = braces $ text "Var: " <> ppr v dataCon :: DataCon -> SDoc dataCon c = braces $ text "DataCon: " <> ppr c bagRdrName:: Bag (Located (HsBind GhcPs)) -> SDoc bagRdrName bg = braces $ text "Bag(Located (HsBind GhcPs)):" $$ (list . bagToList $ bg) bagName :: Bag (Located (HsBind GhcRn)) -> SDoc bagName bg = braces $ text "Bag(Located (HsBind Name)):" $$ (list . bagToList $ bg) bagVar :: Bag (Located (HsBind GhcTc)) -> SDoc bagVar bg = braces $ text "Bag(Located (HsBind Var)):" $$ (list . bagToList $ bg) nameSet ns = braces $ text "NameSet:" $$ (list . nameSetElemsStable $ ns) fixity :: Fixity -> SDoc fixity fx = braces $ text "Fixity: " <> ppr fx located :: (Data b,Data loc) => GenLocated loc b -> SDoc located (L ss a) = parens $ case cast ss of Just (s :: SrcSpan) -> srcSpan s Nothing -> text "nnnnnnnn" $$ showAstData' a normalize_newlines :: String -> String normalize_newlines ('\\':'r':'\\':'n':xs) = '\\':'n':normalize_newlines xs normalize_newlines (x:xs) = x:normalize_newlines xs normalize_newlines [] = [] {- ************************************************************************ * * * Copied from syb * * ************************************************************************ -} -- | The type constructor for queries newtype Q q x = Q { unQ :: x -> q } -- | Extend a generic query by a type-specific case extQ :: ( Typeable a , Typeable b ) => (a -> q) -> (b -> q) -> a -> q extQ f g a = maybe (f a) g (cast a) -- | Type extension of queries for type constructors ext1Q :: (Data d, Typeable t) => (d -> q) -> (forall e. Data e => t e -> q) -> d -> q ext1Q def ext = unQ ((Q def) `ext1` (Q ext)) -- | Type extension of queries for type constructors ext2Q :: (Data d, Typeable t) => (d -> q) -> (forall d1 d2. (Data d1, Data d2) => t d1 d2 -> q) -> d -> q ext2Q def ext = unQ ((Q def) `ext2` (Q ext)) -- | Flexible type extension ext1 :: (Data a, Typeable t) => c a -> (forall d. Data d => c (t d)) -> c a ext1 def ext = maybe def id (dataCast1 ext) -- | Flexible type extension ext2 :: (Data a, Typeable t) => c a -> (forall d1 d2. (Data d1, Data d2) => c (t d1 d2)) -> c a ext2 def ext = maybe def id (dataCast2 ext) # endif #endif ghc-lib-parser-ex-9.12.0.0/src/Language/Haskell/GhclibParserEx/GHC/Hs/Expr.hs0000644000000000000000000003276507346545000024344 0ustar0000000000000000-- Copyright (c) 2020-2024, Shayne Fletcher. All rights reserved. -- SPDX-License-Identifier: BSD-3-Clause. {- ORMOLU_DISABLE -} {-# OPTIONS_GHC -Wno-missing-fields #-} {-# 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, isDo, isLexeme, isLambda, isQuasiQuote, isQuasiQuoteExpr, isQuasiQuoteSplice, isOverLabel, isDotApp, isTypeApp, isWHNF, isLCase, isFieldPun, isFieldPunUpdate, isRecStmt, isLetStmt, isParComp, isMDo, isListComp, isMonadComp, isTupleSection, isString, isPrimLiteral, isSpliceDecl, #if !( defined (GHC_9_4) || defined (GHC_9_2) || defined (GHC_9_0) || defined (GHC_8_10) || defined (GHC_8_8) ) -- ghc api >= 9.6.1 isTypedSplice, isUntypedSplice, #endif isFieldWildcard, isUnboxed, isWholeFrac, isStrictMatch, isMultiIf, isProc, isTransStmt, hasFieldsDotDot, varToStr, strToVar, fromChar ) where #if defined (GHC_8_8) import HsSyn import SrcLoc import RdrName import OccName import Name import BasicTypes import TysWiredIn #elif defined (GHC_8_10) import GHC.Hs import SrcLoc import RdrName import OccName import Name import BasicTypes import TysWiredIn #elif defined (GHC_9_0) import GHC.Hs import GHC.Types.SrcLoc import GHC.Types.Name.Reader import GHC.Types.Name import GHC.Types.Basic import GHC.Builtin.Types #elif defined (GHC_9_2) || defined (GHC_9_4) import GHC.Hs import GHC.Types.SourceText import GHC.Types.SrcLoc import GHC.Types.Name.Reader import GHC.Types.Name import GHC.Types.Basic import GHC.Builtin.Types #else import GHC.Hs import GHC.Types.SourceText import GHC.Types.SrcLoc import GHC.Types.Name.Reader import GHC.Types.Name import GHC.Types.Basic import GHC.Builtin.Types import Language.Haskell.GhclibParserEx.GHC.Types.Name.Reader #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, isDo, 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 isDo = \case (L _ HsDo{}) -> True; _ -> False isLexeme = \case (L _ HsVar{}) -> True; (L _ HsOverLit{}) -> True; (L _ HsLit{}) -> True; _ -> False -- 'isLambda' semantics are match form `\p -> e` exclusively #if ! ( defined (GHC_9_8) || defined (GHC_9_6) || defined (GHC_9_4) || defined (GHC_9_2) || defined (GHC_9_0) || defined (GHC_8_10) || defined (GHC_8_8) ) --ghc api >= 9.8.1 isLambda = \case (L _ (HsLam _ LamSingle _)) -> True; _ -> False #else isLambda = \case (L _ HsLam{}) -> True; _ -> False #endif #if ! ( defined (GHC_9_4) || defined (GHC_9_2) || defined (GHC_9_0) || defined (GHC_8_10) || defined (GHC_8_8) ) -- ghc api >= 9.6.1 isQuasiQuoteExpr = \case (L _ (HsUntypedSplice _ HsQuasiQuote{})) -> True; _ -> False #else -- ghc api < 9.6.1 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 #if ! ( defined(GHC_9_12) || defined (GHC_9_10) || defined (GHC_9_8) || defined(GHC_9_6) || defined (GHC_9_4) || defined (GHC_9_2) || defined (GHC_9_0) || defined (GHC_8_10) || defined (GHC_8_8) ) -- ghc api > 9.12.1 (L _ (HsLit _ x)) -> case x of HsString{} -> False; _ -> True #else (L _ (HsLit _ x)) -> case x of HsString{} -> False; HsInt{} -> False; HsRat{} -> False; _ -> True #endif (L _ HsLam{}) -> True (L _ ExplicitTuple{}) -> True (L _ ExplicitList{}) -> True #if ! ( defined (GHC_9_8) || defined (GHC_9_6) || defined (GHC_9_4) || defined (GHC_9_2) || defined (GHC_9_0) || defined (GHC_8_10) || defined (GHC_8_8) ) -- ghc api >= 9.8 (L _ (HsPar _ x )) -> isWHNF x #elif ! ( defined (GHC_9_2) || defined (GHC_9_0) || defined (GHC_8_10) || defined (GHC_8_8) ) -- ghc api >= 9.4 (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 #if ! ( defined (GHC_9_8) || defined (GHC_9_6) || defined (GHC_9_4) || defined (GHC_9_2) || defined (GHC_9_0) || defined (GHC_8_10) || defined (GHC_8_8) ) isLCase = \case (L _ (HsLam _ LamCase _)) -> True; _ -> False #else isLCase = \case (L _ HsLamCase{}) -> True; _ -> False #endif isOverLabel = \case (L _ HsOverLabel{}) -> True; _ -> False #if ! ( defined (GHC_9_4) || defined (GHC_9_2) || defined (GHC_9_0) || defined (GHC_8_10) || defined (GHC_8_8) ) -- ghc api >= 9.6.1 isQuasiQuoteSplice :: HsUntypedSplice GhcPs -> Bool #else isQuasiQuoteSplice :: HsSplice GhcPs -> Bool #endif isQuasiQuoteSplice = \case HsQuasiQuote{} -> True; _ -> False #if ( defined (GHC_8_10) || defined (GHC_8_8) ) isStrictMatch :: HsMatchContext RdrName -> Bool #elif ( defined (GHC_9_8) || defined (GHC_9_6) || defined (GHC_9_4) || defined (GHC_9_2) || defined (GHC_9_0) ) isStrictMatch :: HsMatchContext GhcPs -> Bool #else -- ghc > 9.8.1 isStrictMatch :: HsMatchContext (LocatedN RdrName) -> Bool #endif isStrictMatch = \case FunRhs{mc_strictness=SrcStrict} -> True; _ -> False -- Field is punned e.g. '{foo}'. #if ! ( defined (GHC_9_2) || defined (GHC_9_0) || defined (GHC_8_10) || defined (GHC_8_8) ) -- ghc api >= 9.4.1 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 (GHC_9_10) || defined (GHC_9_8) || defined(GHC_9_6) || defined (GHC_9_4) || defined (GHC_9_2) || defined (GHC_9_0) || defined (GHC_8_10) || defined (GHC_8_8) ) -- ghc api > 9.10.1 isFieldPunUpdate :: HsFieldBind (LFieldOcc GhcPs) (LHsExpr GhcPs) -> Bool isFieldPunUpdate = \case HsFieldBind {hfbPun=True} -> True; _ -> False #elif ! ( defined (GHC_9_2) || defined (GHC_9_0) || defined (GHC_8_10) || defined (GHC_8_8) ) -- ghc api >= 9.4.1 && <= 9.12.1 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 isLetStmt :: StmtLR GhcPs GhcPs (LHsExpr GhcPs) -> Bool isLetStmt = \case LetStmt{} -> 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 (GHC_9_2) || defined (GHC_9_0) || defined (GHC_8_10) || defined (GHC_8_8) ) -- ghc api >= 9.4.1 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 (GHC_9_2) || defined (GHC_9_0) 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 -- Since ghc-9.6.1, `HsTypedSplice` and `HsUntypedSplice` have been -- top-level constuctors of `Language.Haskell.Syntax.Expr.HsExpr p` #if ! ( defined (GHC_9_4) || defined (GHC_9_2) || defined (GHC_9_0) || defined (GHC_8_10) || defined (GHC_8_8) ) -- ghc api >= ghc-9.6.1 isTypedSplice, isUntypedSplice :: HsExpr GhcPs -> Bool isTypedSplice = \case HsTypedSplice{} -> True; _ -> False isUntypedSplice = \case HsUntypedSplice{} -> True; _ -> False #endif isSpliceDecl :: HsExpr GhcPs -> Bool #if ! ( defined (GHC_9_4) || defined (GHC_9_2) || defined (GHC_9_0) || defined (GHC_8_10) || defined (GHC_8_8) ) -- ghc api >= 9.6.1 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 (GHC_9_2) || defined (GHC_9_0) || defined (GHC_8_10) || defined (GHC_8_8) ) -- ghc api >= 9.4.1 isFieldWildcard :: LHsFieldBind GhcPs (LFieldOcc GhcPs) (LHsExpr GhcPs) -> Bool #else isFieldWildcard :: LHsRecField GhcPs (LHsExpr GhcPs) -> Bool #endif isFieldWildcard = \case #if ! ( defined (GHC_9_4) || defined (GHC_9_2) || defined (GHC_9_0) || defined (GHC_8_10) || defined (GHC_8_8) ) -- ghc api >= ghc-9.6.1 -- Use `Language.Haskell.GhcLibParserEx.GHC.Types.Name.Reader`s `occNameStr` since `HsUnboundVar` now contains a `RdrName` not an `OccName`. (L _ HsFieldBind {hfbRHS=(L _ (HsUnboundVar _ s))}) -> occNameStr s == "_" #elif defined (GHC_9_4) (L _ HsFieldBind {hfbRHS=(L _ (HsUnboundVar _ s))}) -> occNameString s == "_" #elif defined (GHC_9_2) || defined (GHC_9_0) (L _ HsRecField {hsRecFieldArg=(L _ (HsUnboundVar _ s))}) -> occNameString s == "_" #elif defined (GHC_8_10) (L _ HsRecField {hsRecFieldArg=(L _ (HsUnboundVar _ _))}) -> True #else (L _ HsRecField {hsRecFieldArg=(L _ (EWildPat _))}) -> True #endif #if ! (defined (GHC_9_2) || defined (GHC_9_0) || defined (GHC_8_10) || defined (GHC_8_8) ) -- ghc api >= 9.4.1 (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(GHC_9_12) || defined (GHC_9_10) || defined (GHC_9_8) || defined(GHC_9_6) || defined (GHC_9_4) || defined (GHC_9_2) || defined (GHC_9_0) || defined (GHC_8_10) || defined (GHC_8_8) ) -- ghc api > 9.12.1 isWholeFrac (HsOverLit _ (OverLit _ (HsFractional fl@FL {}) )) = denominator (rationalFromFractionalLit fl) == 1 #elif ! (defined (GHC_9_2) || defined (GHC_9_0) || defined (GHC_8_10) || defined (GHC_8_8) ) -- ghc api >= 9.4.1 isWholeFrac (HsLit _ (HsRat _ fl@FL{} _)) = denominator (rationalFromFractionalLit fl) == 1 isWholeFrac (HsOverLit _ (OverLit _ (HsFractional fl@FL {}) )) = denominator (rationalFromFractionalLit fl) == 1 #elif defined (GHC_9_2) 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 (GHC_9_0) || defined (GHC_8_10) || defined (GHC_8_8) ) -- ghc api >= 9.2.1 strToVar x = noLocA $ HsVar noExtField (noLocA $ mkRdrUnqual (mkVarOcc x)) #elif defined (GHC_9_0) || defined (GHC_8_10) 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 ghc-lib-parser-ex-9.12.0.0/src/Language/Haskell/GhclibParserEx/GHC/Hs/ExtendInstances.hs0000644000000000000000000000417707346545000026521 0ustar0000000000000000-- Copyright (c) 2020-2023, Shayne Fletcher. All rights reserved. -- SPDX-License-Identifier: BSD-3-Clause. {- ORMOLU_DISABLE -} {-# LANGUAGE GeneralizedNewtypeDeriving #-} #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 (GHC_8_8) || defined (GHC_8_10)) import GHC.Utils.Outputable #else import Outputable #endif import Data.Data import Data.Function import Language.Haskell.GhclibParserEx.GHC.Hs.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 (GHC_9_0) || defined (GHC_8_10) || defined (GHC_8_8) ) 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 (GHC_9_0) || defined (GHC_8_10) || defined (GHC_8_8) ) showPprUnsafe $ ppr e #else showSDocUnsafe $ ppr e #endif ghc-lib-parser-ex-9.12.0.0/src/Language/Haskell/GhclibParserEx/GHC/Hs/ImpExp.hs0000644000000000000000000000266607346545000024625 0ustar0000000000000000-- Copyright (c) 2020-2023 Shayne Fletcher. All rights reserved. -- SPDX-License-Identifier: BSD-3-Clause. {- ORMOLU_DISABLE -} #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 (GHC_8_8) import HsImpExp import RdrName #elif defined (GHC_8_10) import GHC.Hs.ImpExp import RdrName #elif defined (GHC_9_0) || defined (GHC_9_2) || defined (GHC_9_4) import GHC.Hs.ImpExp import GHC.Types.Name.Reader #else import GHC.Hs.ImpExp import GHC.Hs.Extension (GhcPs) #endif #if !( defined (GHC_9_4) || defined (GHC_9_2) || defined (GHC_9_0) || defined (GHC_8_10) || defined (GHC_8_8) ) 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 ghc-lib-parser-ex-9.12.0.0/src/Language/Haskell/GhclibParserEx/GHC/Hs/Pat.hs0000644000000000000000000001456107346545000024144 0ustar0000000000000000-- Copyright (c) 2020-203, Shayne Fletcher. All rights reserved. -- SPDX-License-Identifier: BSD-3-Clause. {-# LANGUAGE ViewPatterns #-} #include "ghclib_api.h" module Language.Haskell.GhclibParserEx.GHC.Hs.Pat ( patToStr, strToPat, fromPChar, hasPFieldsDotDot, isPFieldWildcard, isPWildcard, isPFieldPun, isPatTypeSig, isPBangPat, isPViewPat, isWildPat {- alias for 'isPWildcard' -}, isSplicePat, ) where #if defined (GHC_8_8) import HsSyn import SrcLoc import TysWiredIn import RdrName import OccName import FastString #elif defined (GHC_8_10) import GHC.Hs import SrcLoc import TysWiredIn import RdrName import OccName import FastString #else import GHC.Hs import GHC.Types.SrcLoc import GHC.Builtin.Types import GHC.Types.Name.Reader import GHC.Types.Name import GHC.Data.FastString #endif patToStr :: LPat GhcPs -> String #if defined (GHC_8_8) 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 _ = "" #elif defined (GHC_8_10) 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 _ = "" #elif defined (GHC_9_0) 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 _ = "" #else 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 _ = "" #endif strToPat :: String -> LPat GhcPs strToPat z #if defined (GHC_8_8) | z == "True" = ConPatIn (noLoc true_RDR) (PrefixCon []) | z == "False" = ConPatIn (noLoc false_RDR) (PrefixCon []) | z == "[]" = ConPatIn (noLoc $ nameRdrName nilDataConName) (PrefixCon []) | otherwise = VarPat noExt (noLoc $ mkVarUnqual (fsLit z)) #elif defined (GHC_8_10) | z == "True" = noLoc $ ConPatIn (noLoc true_RDR) (PrefixCon []) | z == "False" = noLoc $ ConPatIn (noLoc false_RDR) (PrefixCon []) | z == "[]" = noLoc $ ConPatIn (noLoc $ nameRdrName nilDataConName) (PrefixCon []) | otherwise = noLoc $ VarPat noExtField (noLoc $ mkVarUnqual (fsLit z)) #elif defined (GHC_9_0) | z == "True" = noLoc $ ConPat noExtField (noLoc true_RDR) (PrefixCon []) | z == "False" = noLoc $ ConPat noExtField (noLoc false_RDR) (PrefixCon []) | z == "[]" = noLoc $ ConPat noExtField (noLoc $ nameRdrName nilDataConName) (PrefixCon []) | otherwise = noLoc $ VarPat noExtField (noLoc $ mkVarUnqual (fsLit z)) #else | z == "True" = noLocA $ ConPat noAnn (noLocA true_RDR) (PrefixCon [] []) | z == "False" = noLocA $ ConPat noAnn (noLocA false_RDR) (PrefixCon [] []) | z == "[]" = noLocA $ ConPat noAnn (noLocA $ nameRdrName nilDataConName) (PrefixCon [] []) | otherwise = noLocA $ VarPat noExtField (noLocA $ mkVarUnqual (fsLit z)) #endif fromPChar :: LPat GhcPs -> Maybe Char #if defined (GHC_8_8) fromPChar (dL -> L _ (LitPat _ (HsChar _ x))) = Just x #else fromPChar (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 (GHC_9_2) || defined (GHC_9_0) || defined (GHC_9_0) || defined (GHC_8_10) || defined (GHC_8_8) ) -- ghc >= 9.4 isPFieldWildcard :: LHsFieldBind GhcPs (LFieldOcc GhcPs) (LPat GhcPs) -> Bool #else isPFieldWildcard :: LHsRecField GhcPs (LPat GhcPs) -> Bool #endif #if defined (GHC_8_8) isPFieldWildcard (dL -> L _ HsRecField {hsRecFieldArg=LL _ WildPat {}}) = True isPFieldWildcard (dL -> L _ HsRecField {hsRecPun=True}) = True isPFieldWildcard (dL -> L _ HsRecField {}) = False #elif defined (GHC_8_10) isPFieldWildcard (L _ HsRecField {hsRecFieldArg=L _ WildPat {}}) = True isPFieldWildcard (L _ HsRecField {hsRecPun=True}) = True isPFieldWildcard (L _ HsRecField {}) = False #elif defined (GHC_9_0) || defined (GHC_9_2) isPFieldWildcard (L _ HsRecField {hsRecFieldArg=L _ WildPat {}}) = True isPFieldWildcard (L _ HsRecField {hsRecPun=True}) = True isPFieldWildcard (L _ HsRecField {}) = False #else isPFieldWildcard (L _ HsFieldBind {hfbRHS=L _ WildPat {}}) = True isPFieldWildcard (L _ HsFieldBind {hfbPun=True}) = True isPFieldWildcard (L _ HsFieldBind {}) = False #endif isPWildcard :: LPat GhcPs -> Bool #if defined (GHC_8_8) isPWildcard (dL -> L _ (WildPat _)) = True #else isPWildcard (L _ (WildPat _)) = True #endif isPWildcard _ = False isWildPat :: LPat GhcPs -> Bool isWildPat = isPWildcard #if !( defined (GHC_9_2) || defined (GHC_9_0) || defined (GHC_9_0) || defined (GHC_8_10) || defined (GHC_8_8) ) isPFieldPun :: LHsFieldBind GhcPs (LFieldOcc GhcPs) (LPat GhcPs) -> Bool #else isPFieldPun :: LHsRecField GhcPs (LPat GhcPs) -> Bool #endif #if defined (GHC_8_8) isPFieldPun (dL -> L _ HsRecField {hsRecPun=True}) = True #elif defined (GHC_8_10) || defined (GHC_9_0) || defined (GHC_9_2) isPFieldPun (L _ HsRecField {hsRecPun=True}) = True #else isPFieldPun (L _ HsFieldBind {hfbPun=True}) = True #endif isPFieldPun _ = False isPatTypeSig, isPBangPat, isPViewPat :: LPat GhcPs -> Bool #if defined (GHC_8_8) isPatTypeSig (dL -> L _ SigPat{}) = True; isPatTypeSig _ = False isPBangPat (dL -> L _ BangPat{}) = True; isPBangPat _ = False isPViewPat (dL -> L _ ViewPat{}) = True; isPViewPat _ = False #else isPatTypeSig (L _ SigPat{}) = True; isPatTypeSig _ = False isPBangPat (L _ BangPat{}) = True; isPBangPat _ = False isPViewPat (L _ ViewPat{}) = True; isPViewPat _ = False #endif isSplicePat :: LPat GhcPs -> Bool #if defined (GHC_8_8) isSplicePat (dL -> L _ SplicePat{}) = True; isSplicePat _ = False #else isSplicePat (L _ SplicePat{}) = True; isSplicePat _ = False #endif ghc-lib-parser-ex-9.12.0.0/src/Language/Haskell/GhclibParserEx/GHC/Hs/Type.hs0000644000000000000000000000155707346545000024342 0ustar0000000000000000-- Copyright (c) 2021-2023, Shayne Fletcher. All rights reserved. -- SPDX-License-Identifier: BSD-3-Clause. {-# LANGUAGE LambdaCase #-} #include "ghclib_api.h" module Language.Haskell.GhclibParserEx.GHC.Hs.Type ( fromTyParen, isTyQuasiQuote, isUnboxedTuple, isKindTyApp, ) where #if defined (GHC_8_8) import HsSyn #else import GHC.Hs #endif #if defined (GHC_8_8) || defined (GHC_8_10) import SrcLoc #else import GHC.Types.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 ghc-lib-parser-ex-9.12.0.0/src/Language/Haskell/GhclibParserEx/GHC/Hs/Types.hs0000644000000000000000000000054107346545000024515 0ustar0000000000000000-- 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 ghc-lib-parser-ex-9.12.0.0/src/Language/Haskell/GhclibParserEx/GHC/Parser.hs0000644000000000000000000001321307346545000024273 0ustar0000000000000000-- Copyright (c) 2020-2024, Shayne Fletcher. All rights reserved. -- SPDX-License-Identifier: BSD-3-Clause. {- ORMOLU_DISABLE -} #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 (GHC_8_8) import HsSyn import DynFlags import StringBuffer import Lexer import qualified Parser import FastString import SrcLoc import BkpSyn import PackageConfig import RdrName #elif defined (GHC_8_10) import GHC.Hs import DynFlags import StringBuffer import Lexer import qualified Parser import FastString import SrcLoc import BkpSyn import PackageConfig import RdrName import RdrHsSyn #elif defined (GHC_9_0) import GHC.Hs 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 #elif defined (GHC_9_2) import GHC.Hs import GHC.Driver.Config 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 GHC.Hs import GHC.Driver.Config.Parser 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 #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 (GHC_9_0) || defined (GHC_8_10) || defined (GHC_8_8) ) initParserState (initParserOpts flags) buffer location #else mkPState flags buffer location #endif #if defined (GHC_9_4) || defined(GHC_9_2) || defined (GHC_9_0) parseModule :: String -> DynFlags -> ParseResult (Located HsModule) #else parseModule :: String -> DynFlags -> ParseResult (Located (HsModule GhcPs)) #endif parseModule = parse Parser.parseModule #if defined (GHC_9_4) || defined(GHC_9_2) || defined (GHC_9_0) 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 (GHC_9_0) || defined (GHC_8_10) || defined (GHC_8_8) ) parseExpression s flags = 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 (GHC_8_10) || defined (GHC_9_0) 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 (GHC_9_0) || defined (GHC_8_10) || defined (GHC_8_8) ) 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 (GHC_9_4) || defined(GHC_9_2) || defined (GHC_9_0) parseHeader :: String -> DynFlags -> ParseResult (Located HsModule) #else parseHeader :: String -> DynFlags -> ParseResult (Located (HsModule GhcPs)) #endif parseHeader = parse Parser.parseHeader #if defined (GHC_9_4) || defined(GHC_9_2) || defined (GHC_9_0) 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 (GHC_9_0) || defined (GHC_8_10) || defined (GHC_8_8) ) initParserState (initParserOpts flags) buffer location #else mkPState flags buffer location #endif ghc-lib-parser-ex-9.12.0.0/src/Language/Haskell/GhclibParserEx/GHC/Settings/0000755000000000000000000000000007346545000024303 5ustar0000000000000000ghc-lib-parser-ex-9.12.0.0/src/Language/Haskell/GhclibParserEx/GHC/Settings/Config.hs0000644000000000000000000000774507346545000026061 0ustar0000000000000000-- Copyright (c) 2020-2024, Shayne Fletcher. All rights reserved. -- SPDX-License-Identifier: BSD-3-Clause. {- ORMOLU_DISABLE -} {-# OPTIONS_GHC -Wno-missing-fields #-} #include "ghclib_api.h" module Language.Haskell.GhclibParserEx.GHC.Settings.Config( fakeSettings #if defined (GHC_8_8) || defined (GHC_8_10) || defined (GHC_9_0) || defined (GHC_9_2) || defined (GHC_9_4) , fakeLlvmConfig #endif ) where #if defined (GHC_8_8) import Config import DynFlags import Fingerprint import Platform #elif defined (GHC_8_10) import Config import DynFlags import Fingerprint import GHC.Platform import ToolSettings #else import GHC.Settings.Config import GHC.Driver.Session import GHC.Utils.Fingerprint import GHC.Platform import GHC.Settings #endif #if ! (defined (GHC_9_12) || defined (GHC_9_10) || defined (GHC_9_8) || defined (GHC_9_6) || defined (GHC_9_4) || defined (GHC_9_2) || defined (GHC_9_0) || defined (GHC_8_10) || defined (GHC_8_8)) {- since 9.14 -} import GHC.Unit.Types (stringToUnitId) #endif fakeSettings :: Settings fakeSettings = Settings #if defined (GHC_8_8) { sTargetPlatform=platform , sPlatformConstants=platformConstants , sProjectVersion=cProjectVersion , sProgramName="ghc" , sOpt_P_fingerprint=fingerprint0 } #elif defined (GHC_8_10) || defined (GHC_9_0) { sGhcNameVersion=ghcNameVersion , sFileSettings=fileSettings , sTargetPlatform=platform , sPlatformMisc=platformMisc , sPlatformConstants=platformConstants , sToolSettings=toolSettings } #elif (defined (GHC_9_2) || defined (GHC_9_4) || defined (GHC_9_6) || defined (GHC_9_8) || defined (GHC_9_10) || defined (GHC_9_12)) { sGhcNameVersion=ghcNameVersion , sFileSettings=fileSettings , sTargetPlatform=platform , sPlatformMisc=platformMisc , sToolSettings=toolSettings } #else {- defined (GHC_9_14) -} { sGhcNameVersion=ghcNameVersion , sFileSettings=fileSettings , sTargetPlatform=platform , sPlatformMisc=platformMisc , sToolSettings=toolSettings , sUnitSettings=unitSettings } #endif where #if !(defined (GHC_8_8) || defined (GHC_8_10) || defined (GHC_9_0) || defined (GHC_9_2) || (defined GHC_9_4) || defined (GHC_9_6) || defined (GHC_9_8) || defined (GHC_9_10) || defined (GHC_9_12)) {- ghc-api>=9.14.1 -} unitSettings = UnitSettings { unitSettings_baseUnitId = stringToUnitId "base" } #endif #if !defined (GHC_8_8) toolSettings = ToolSettings { toolSettings_opt_P_fingerprint=fingerprint0 } fileSettings = FileSettings {} platformMisc = PlatformMisc {} ghcNameVersion = GhcNameVersion { ghcNameVersion_programName="ghc" , ghcNameVersion_projectVersion=cProjectVersion } #endif #if defined (GHC_8_8) || defined (GHC_8_10) || defined (GHC_9_0) platformConstants = PlatformConstants { pc_DYNAMIC_BY_DEFAULT=False , pc_WORD_SIZE=8 } #endif #if defined (GHC_8_8) platform = Platform { platformWordSize=8 , platformOS=OSUnknown , platformUnregisterised=True } #elif defined (GHC_8_10) platform = Platform { platformWordSize=PW8 , platformMini=PlatformMini { platformMini_arch=ArchUnknown , platformMini_os=OSUnknown } , platformUnregisterised=True } #elif defined (GHC_9_0) platform = Platform { platformByteOrder=LittleEndian , platformHasGnuNonexecStack=True , platformHasIdentDirective=False , platformHasSubsectionsViaSymbols=False , platformIsCrossCompiling=False , platformLeadingUnderscore=False , platformTablesNextToCode=False , platformWordSize=PW8 , platformMini=PlatformMini {platformMini_arch=ArchUnknown, platformMini_os=OSUnknown} , platformUnregisterised=True } #else platform = genericPlatform #endif #if defined (GHC_8_8) fakeLlvmConfig :: (LlvmTargets, LlvmPasses) fakeLlvmConfig = ([], []) #elif defined (GHC_8_10) || defined (GHC_9_0) || defined(GHC_9_2) || defined(GHC_9_4) fakeLlvmConfig :: LlvmConfig fakeLlvmConfig = LlvmConfig [] [] #endif ghc-lib-parser-ex-9.12.0.0/src/Language/Haskell/GhclibParserEx/GHC/Types/Name/0000755000000000000000000000000007346545000024467 5ustar0000000000000000ghc-lib-parser-ex-9.12.0.0/src/Language/Haskell/GhclibParserEx/GHC/Types/Name/Reader.hs0000644000000000000000000000411407346545000026225 0ustar0000000000000000-- Copyright (c) 2020-2023, Shayne Fletcher. All rights reserved. -- SPDX-License-Identifier: BSD-3-Clause. #include "ghclib_api.h" module Language.Haskell.GhclibParserEx.GHC.Types.Name.Reader ( occNameStr, rdrNameStr, isSpecial, unqual, fromQual, isSymbolRdrName, ) where #if !( defined (GHC_9_0) || defined (GHC_8_10) || defined (GHC_8_8) ) import GHC.Parser.Annotation #endif #if defined (GHC_8_8) || defined (GHC_8_10) import SrcLoc import RdrName import OccName import Name #else import GHC.Types.SrcLoc import GHC.Types.Name import GHC.Types.Name.Reader #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 (GHC_9_0) || defined (GHC_8_10) || defined (GHC_8_8) ) rdrNameStr :: GHC.Parser.Annotation.LocatedN RdrName -> String #else rdrNameStr :: Located RdrName -> String #endif rdrNameStr = occNameStr . unLoc -- Builtin type or data constructors. #if ! ( defined (GHC_9_0) || defined (GHC_8_10) || defined (GHC_8_8) ) 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 (GHC_9_0) || defined (GHC_8_10) || defined (GHC_8_8) ) 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 (GHC_9_0) || defined (GHC_8_10) || defined (GHC_8_8) ) 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 ghc-lib-parser-ex-9.12.0.0/src/Language/Haskell/GhclibParserEx/GHC/Utils/0000755000000000000000000000000007346545000023603 5ustar0000000000000000ghc-lib-parser-ex-9.12.0.0/src/Language/Haskell/GhclibParserEx/GHC/Utils/Outputable.hs0000644000000000000000000000107207346545000026263 0ustar0000000000000000-- Copyright (c) 2020-2023, Shayne Fletcher. All rights reserved. -- SPDX-License-Identifier: BSD-3-Clause. {- ORMOLU_DISABLE -} #include "ghclib_api.h" module Language.Haskell.GhclibParserEx.GHC.Utils.Outputable ( unsafePrettyPrint ) where #if defined (GHC_8_8) || defined (GHC_8_10) import Outputable #else import GHC.Utils.Outputable #endif unsafePrettyPrint :: Outputable a => a -> String unsafePrettyPrint = #if ! ( defined (GHC_9_2) || defined (GHC_9_0) || defined (GHC_8_10) || defined (GHC_8_8) ) showPprUnsafe . ppr #else showSDocUnsafe . ppr #endif ghc-lib-parser-ex-9.12.0.0/test/0000755000000000000000000000000007346545000014322 5ustar0000000000000000ghc-lib-parser-ex-9.12.0.0/test/Test.hs0000644000000000000000000006030507346545000015601 0ustar0000000000000000-- Copyright (c) 2020, Shayne Fletcher. All rights reserved. -- SPDX-License-Identifier: BSD-3-Clause. {-# 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.Data import Data.List.Extra import Data.Maybe import Data.Generics.Uniplate.Data #if !(defined (GHC_9_0) || defined (GHC_8_10) || defined (GHC_8_8)) import GHC.Data.Bag # if !defined (GHC_9_2) import GHC.Driver.Errors.Types # endif import GHC.Types.Error #endif import Language.Haskell.GhclibParserEx.GHC.Hs.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 (GHC_8_8) -- ghc >= 8.10 import GHC.Hs #else import HsSyn #endif #if !( defined (GHC_8_10) || defined (GHC_8_8) ) -- ghc >= 9.0 import GHC.Types.SrcLoc import GHC.Driver.Session import GHC.Parser.Lexer # if defined (GHC_9_4) || defined (GHC_9_2) || defined (GHC_9_0) -- 9.0 <= ghc <= 9.4 import GHC.Utils.Outputable # endif # if !defined (GHC_9_0) -- ghc >= 9.2 import GHC.Driver.Ppr # if defined (GHC_9_2) -- ghc = 9.2 import GHC.Parser.Errors.Ppr # endif # endif import GHC.Utils.Error import GHC.Types.Name.Reader import GHC.Types.Name.Occurrence #else -- ghc < 9.0 import SrcLoc import DynFlags import Lexer import Outputable import ErrUtils import RdrName import OccName #endif #if defined (GHC_8_8) -- ghc = 8.8 import Bag #endif import GHC.LanguageExtensions.Type basicDynFlags :: DynFlags basicDynFlags = defaultDynFlags fakeSettings #if defined (GHC_9_4) || defined (GHC_9_2) || defined (GHC_9_0) || defined (GHC_8_10) || defined (GHC_8_8) -- ghc <= 9.4 fakeLlvmConfig #endif main :: IO () main = do setEnv "TASTY_NUM_THREADS" "1" setUnsafeGlobalDynFlags basicDynFlags defaultMain tests tests :: TestTree tests = testGroup " All tests" [ parseTests , fixityTests , extendInstancesTests , expressionPredicateTests , declarationPredicateTests , 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 (GHC_9_4) || defined (GHC_9_2) || defined (GHC_9_0) || defined (GHC_8_10) || defined (GHC_8_8)) -- ghc >= 9.6 report :: DynFlags -> Bag (MsgEnvelope GhcMessage) -> String report flags msgs = concat [ showSDoc flags msg | msg <- pprMsgEnvelopeBagWithLocDefault msgs ] #elif defined (GHC_9_4) report :: DynFlags -> Bag (MsgEnvelope GhcMessage) -> String report flags msgs = concat [ showSDoc flags msg | msg <- pprMsgEnvelopeBagWithLoc msgs ] #elif defined (GHC_9_2) 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 chkParseResult :: DynFlags -> ParseResult a -> IO () chkParseResult flags = \case POk s _ -> do #if !(defined (GHC_9_2) || defined (GHC_9_0) || defined (GHC_8_10) || defined (GHC_8_8)) -- ghc >= 9.4 let (wrns, errs) = getPsMessages s #elif defined (GHC_9_2) let (wrns, errs) = getMessages s #else let (wrns, errs) = getMessages s flags #endif when (not (null errs) || not (null wrns)) $ #if !(defined (GHC_9_2) || defined (GHC_9_0) || defined (GHC_8_10) || defined (GHC_8_8)) -- ghc >= 9.4 assertFailure ( report flags (getMessages (GhcPsMessage <$> wrns)) ++ report flags (getMessages (GhcPsMessage <$> errs)) ) #elif defined (GHC_9_2) assertFailure (report flags (fmap pprWarning wrns) ++ report flags (fmap pprError errs)) #else assertFailure (report flags wrns ++ report flags errs) #endif #if !(defined (GHC_9_2) || defined (GHC_9_0) || defined (GHC_8_10) || defined (GHC_8_8)) -- ghc >= 9.4 PFailed s -> assertFailure (report flags $ getMessages (GhcPsMessage <$> snd (getPsMessages s))) #elif defined (GHC_9_2) PFailed s -> assertFailure (report flags $ fmap pprError (snd (getMessages s))) #elif defined (GHC_9_0) || defined (GHC_8_10) PFailed s -> assertFailure (report flags $ snd (getMessages s flags)) #else PFailed _ loc err -> assertFailure (report flags $ unitBag $ mkPlainErrMsg flags loc err) #endif hasS :: (Data x, Data a) => (a -> Bool) -> x -> Bool hasS test = any test . universeBi 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" , "import Data.List" , "import Data.Maybe" , "readMany = unfoldr $ listToMaybe . concatMap reads . tails" ] s <- readFile' foo parsePragmasIntoDynFlags flags ([], []) foo s >>= \case Left msg -> assertFailure msg Right flags -> chkParseResult flags (parseFile foo flags s) ] where flags = basicDynFlags #if defined (GHC_9_4) || defined (GHC_9_2) || defined (GHC_9_0) 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" declTest :: String -> DynFlags -> (LHsDecl GhcPs -> IO ()) -> IO () declTest s flags test = case parseDeclaration s flags of POk _ e -> test e _ -> assertFailure "parse error" stmtTest :: String -> DynFlags -> (LStmt GhcPs (LHsExpr GhcPs) -> IO ()) -> IO () stmtTest s flags test = case parseStatement 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" fixityTests :: TestTree fixityTests = testGroup "Fixity tests" [ testCase "Expression" $ exprTest "1 + 2 * 3" flags (\e -> assertBool "parse tree not affected" $ #if !(defined (GHC_9_0) || defined (GHC_8_10) || defined (GHC_8_8)) -- ghc >= 9.2 showSDocUnsafe (showAstData BlankSrcSpan BlankEpAnnotations e) /= showSDocUnsafe (showAstData BlankSrcSpan BlankEpAnnotations (applyFixities [] e)) #else showSDocUnsafe (showAstData BlankSrcSpan e) /= showSDocUnsafe (showAstData BlankSrcSpan (applyFixities [] e)) #endif ) , testCase "Pattern" $ case parseDeclaration "f (1 : 2 :[]) = 1" flags of POk _ d -> assertBool "parse tree not affected" $ #if !(defined (GHC_9_0) || defined (GHC_8_10) || defined (GHC_8_8)) -- ghc >= 9.2 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 declarationPredicateTests :: TestTree declarationPredicateTests = testGroup "Declaration predicate tests" [ testCase "isStrictMatch" $ test "x = e" $ assert' . not . hasS isStrictMatch , testCase "isStrictMatch" $ test "!x = e" $ assert' . hasS isStrictMatch ] where assert' = assertBool "" test s = declTest s (flags [ BangPatterns ]) 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 (GHC_9_8) || defined (GHC_9_6) || defined (GHC_9_4) || defined (GHC_9_2) || defined (GHC_9_0) || defined (GHC_8_10) || defined (GHC_8_8)) -- ghc >= 9.8 , testCase "isSection" $ test "(1 +)" $ \case L _ (HsPar _ x) -> assert' $ isSection x; _ -> assertFailure "unexpected" #elif !(defined (GHC_9_2) || defined (GHC_9_0) || defined (GHC_8_10) || defined (GHC_8_8)) -- ghc >= 9.4 , 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 (GHC_9_8) || defined (GHC_9_6) || defined (GHC_9_4) || defined (GHC_9_2) || defined (GHC_9_0) || defined (GHC_8_10) || defined (GHC_8_8)) -- ghc >= 9.8 , testCase "isSection" $ test "(+ 1)" $ \case L _ (HsPar _ x) -> assert' $ isSection x; _ -> assertFailure "unexpected" #elif !(defined (GHC_9_2) || defined (GHC_9_0) || defined (GHC_8_10) || defined (GHC_8_8)) -- ghc >= 9.4 , 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 "isDo" $ test "do pure ()" $ assert' . isDo , testCase "isDo" $ test "12" $ assert' . not . isDo , 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_with_exts [ LambdaCase ] "\\case _ -> 12" $ assert' . not . 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 (GHC_8_8) || defined (GHC_8_10) , 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 #if !(defined (GHC_9_4) || defined (GHC_9_2) || defined (GHC_9_0) || defined (GHC_8_10) || defined (GHC_8_8)) -- ghc api >= 9.6.1 , testCase "isTypedSplice" $ test "$$foo" $ assert' . isTypedSplice . unLoc , testCase "isTypedSplice" $ test "$foo" $ assert' . not . isTypedSplice . unLoc , testCase "isUntypedSplice" $ test "$foo" $ assert' . isUntypedSplice . unLoc , testCase "isUntypedSplice" $ test "$$foo" $ assert' . not . isUntypedSplice . unLoc #endif , 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 "[ x + y | x <- Just 1, y <- Just 2 ]" $ assert' . not . any isMonadComp . universeBi , testCase "isMonadComp (3)" $ test "[ 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 , testCase "isLetStmt" $ test_stmt "let x = 12" $ assert' . isLetStmt . unLoc , testCase "isLetStmt" $ test_stmt "x <- pure 12" $ assert' . not . isLetStmt . unLoc , testCase "isRecStmt" $ test_stmt_with_exts [ RecursiveDo ] "rec { xs <- Just (1:xs) }" $ assert' . isRecStmt . unLoc , testCase "isRecStmt" $ test_stmt_with_exts [ RecursiveDo ] "xs <- Just (1 : xs)" $ assert' . not . isRecStmt . unLoc ] where assert' = assertBool "" test s = exprTest s (flags []) test_stmt s = stmtTest s (flags []) test_with_exts exts s = exprTest s (flags exts) test_stmt_with_exts exts s = stmtTest 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 , testCase "isWildPat" $ test "_" $ assert' . isWildPat , testCase "isWildPat" $ test "p@(L _ (VisPat _ pat))" $ assert' . not . isWildPat ] 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