diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,3 +1,17 @@ # Changelog for ghc-lib-parser-ex -## 8.8.1.20191204, released 2020-01-18 +## Unreleased changes + +## 0.20200201 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 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,4 +1,4 @@ -# ghc-lib-parser-ex [![Build Status](https://shayne-fletcher.visualstudio.com/ghc-lib-parser-ex/_apis/build/status/shayne-fletcher.ghc-lib-parser-ex?branchName=master)](https://shayne-fletcher.visualstudio.com/ghc-lib-parser-ex/_build/latest?definitionId=1&branchName=master) +# ghc-lib-parser-ex [![License BSD3](https://img.shields.io/badge/license-BSD3-brightgreen.svg)](http://opensource.org/licenses/BSD-3-Clause) [![Hackage version](https://img.shields.io/hackage/v/ghc-lib-parser-ex.svg?label=Hackage)](https://hackage.haskell.org/package/ghc-lib-parser-ex) [![Stackage version](https://www.stackage.org/package/ghc-lib-parser-ex/badge/nightly?label=Stackage)](https://www.stackage.org/package/ghc-lib-parser-ex) [![Build Status](https://shayne-fletcher.visualstudio.com/ghc-lib-parser-ex/_apis/build/status/shayne-fletcher.ghc-lib-parser-ex?branchName=master)](https://shayne-fletcher.visualstudio.com/ghc-lib-parser-ex/_build/latest?definitionId=1&branchName=master) Copyright © 2020, Shayne Fletcher. All rights reserved. SPDX-License-Identifier: BSD-3-Clause @@ -6,22 +6,27 @@ ## Using `ghc-lib-parser-ex` -The package `ghc-lib-parser-ex` is available on [Hackage](https://hackage.haskell.org/) e.g. `cabal install ghc-lib-parser-ex`. There are two release streams within the `ghc-lib-parser-ex` name (tracking released `ghc-lib-parser` versions exactly): +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. -* Version 8.10.1 will be the `ghc-lib-parser-ex` for use against `ghc-lib-parser-8.10.1`(or the released GHC 8.10.1); -* Version 0.20190204 is for use against [`ghc-lib-parser-0.20190204`](http://hackage.haskell.org/package/ghc-lib-0.20190204). +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). -### Building `ghc-lib-parser-ex` +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. -You can build with `stack build` and test with `stack test`. You can also produce `ghc-lib-parser-ex` package distributions by executing the CI script (which incidentally builds everything and runs the tests). +## Building `ghc-lib-parser-ex` + +You can build with `stack build` and test with `stack test`. Produce `ghc-lib-parser-ex` package distributions by executing the CI script: ```bash # Setup git clone git@github.com:shayne-fletcher/ghc-lib-parser-ex.git cd ghc-lib-parser-ex stack runhaskell --package extra --package optparse-applicative CI.hs ``` -Run `stack runhaskell --package extra --package optparse-applicative CI.hs -- --help` for more configurability options. +Run `stack runhaskell --package extra --package optparse-applicative CI.hs -- --help` for more options. -## Releasing `ghc-lib` (notes for maintainers) +To run [`hlint`](https://github.com/ndmitchell/hlint) on this repository, `hlint --cpp-include cbits --cpp-define GHCLIB_API_XXX .` (where `XXX` at this time is one of `808`, `810` or `811`). -Build `ghc-lib-parser-ex` using the [above instructions](#building-ghc-lib-parser-ex) and upload the resulting `.tar.gz` files to [Hackage](https://hackage.haskell.org/upload). +## 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). diff --git a/cbits/ghclib_api.h b/cbits/ghclib_api.h --- a/cbits/ghclib_api.h +++ b/cbits/ghclib_api.h @@ -6,7 +6,7 @@ #if !defined(GHCLIB_API_H) # define GHCLIB_API_H -# if !defined(GHCLIB_API_811) && !defined(GHCLIBAPI_810) && !defined(GHCLIB_API_808) +# if !defined(GHCLIB_API_811) && !defined(GHCLIB_API_810) && !defined(GHCLIB_API_808) # if defined(MIN_VERSION_ghc_lib_parser) # if !MIN_VERSION_ghc_lib_parser(1, 0, 0) # define GHCLIB_API_811 diff --git a/ghc-lib-parser-ex.cabal b/ghc-lib-parser-ex.cabal --- a/ghc-lib-parser-ex.cabal +++ b/ghc-lib-parser-ex.cabal @@ -1,6 +1,6 @@ cabal-version: >= 1.18 name: ghc-lib-parser-ex -version: 0.20200102 +version: 0.20200201 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 @@ -12,11 +12,11 @@ category: Development synopsis: Algorithms on GHC parse trees build-type: Simple +tested-with: GHC==8.8.2, GHC==8.6.5 extra-source-files: README.md ChangeLog.md -extra-source-files: - cbits/ghclib_api.h + cbits/ghclib_api.h source-repository head type: git @@ -29,6 +29,9 @@ library exposed-modules: + Language.Haskell.GhclibParserEx.Config + Language.Haskell.GhclibParserEx.DynFlags + Language.Haskell.GhclibParserEx.HsExtendInstances Language.Haskell.GhclibParserEx.Parse Language.Haskell.GhclibParserEx.Outputable Language.Haskell.GhclibParserEx.Dump @@ -47,7 +50,7 @@ ghc-boot-th else build-depends: - ghc-lib-parser == 0.20200102 + ghc-lib-parser include-dirs: cbits install-includes: @@ -67,7 +70,7 @@ ghc-options: -threaded -rtsopts -with-rtsopts=-N build-depends: base >=4.7 && <5 - , tasty >= 1.2.3 + , tasty >= 1.2 , tasty-hunit >= 0.10.0 , directory >= 1.3.3 , filepath >= 1.4.2 @@ -79,5 +82,5 @@ ghc-boot-th else build-depends: - ghc-lib-parser == 0.20200102 + ghc-lib-parser default-language: Haskell2010 diff --git a/src/Language/Haskell/GhclibParserEx/Config.hs b/src/Language/Haskell/GhclibParserEx/Config.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/GhclibParserEx/Config.hs @@ -0,0 +1,75 @@ +-- Copyright (c) 2020, Shayne Fletcher. All rights reserved. +-- SPDX-License-Identifier: BSD-3-Clause. + +{-# OPTIONS_GHC -Wno-missing-fields #-} +{-# LANGUAGE CPP #-} +#include "ghclib_api.h" + +module Language.Haskell.GhclibParserEx.Config( + fakeSettings + , fakeLlvmConfig + ) + where + +import Config +import DynFlags +import Fingerprint + +#if defined (GHCLIB_API_811) || defined (GHCLIB_API_810) +import GHC.Platform +import ToolSettings +#else +import Platform +#endif + +fakeSettings :: Settings +fakeSettings = Settings +#if defined (GHCLIB_API_811) || defined (GHCLIB_API_810) + { sGhcNameVersion=ghcNameVersion + , sFileSettings=fileSettings + , sTargetPlatform=platform + , sPlatformMisc=platformMisc + , sPlatformConstants=platformConstants + , sToolSettings=toolSettings + } +#else + { sTargetPlatform=platform + , sPlatformConstants=platformConstants + , sProjectVersion=cProjectVersion + , sProgramName="ghc" + , sOpt_P_fingerprint=fingerprint0 + } +#endif + where +#if defined (GHCLIB_API_811) || defined (GHCLIB_API_810) + toolSettings = ToolSettings { + toolSettings_opt_P_fingerprint=fingerprint0 + } + fileSettings = FileSettings {} + platformMisc = PlatformMisc {} + ghcNameVersion = + GhcNameVersion{ghcNameVersion_programName="ghc" + ,ghcNameVersion_projectVersion=cProjectVersion + } +#endif + platform = + Platform{ +#if defined (GHCLIB_API_811) || defined (GHCLIB_API_810) + platformWordSize = PW8 + , platformMini = PlatformMini {platformMini_arch=ArchUnknown, platformMini_os=OSUnknown} +#else + platformWordSize=8 + , platformOS=OSUnknown +#endif + , platformUnregisterised=True + } + platformConstants = + PlatformConstants{pc_DYNAMIC_BY_DEFAULT=False,pc_WORD_SIZE=8} + +#if defined (GHCLIB_API_811) || defined (GHCLIB_API_810) +fakeLlvmConfig :: LlvmConfig +fakeLlvmConfig = LlvmConfig [] [] +#else +fakeLlvmConfig :: (LlvmTargets, LlvmPasses) +fakeLlvmConfig = ([], []) +#endif diff --git a/src/Language/Haskell/GhclibParserEx/DynFlags.hs b/src/Language/Haskell/GhclibParserEx/DynFlags.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/GhclibParserEx/DynFlags.hs @@ -0,0 +1,32 @@ +-- Copyright (c) 2020, Shayne Fletcher. All rights reserved. +-- SPDX-License-Identifier: BSD-3-Clause. + +module Language.Haskell.GhclibParserEx.DynFlags( + parsePragmasIntoDynFlags + ) where + +import DynFlags +import Panic +import HeaderInfo +import StringBuffer +import HscTypes +import GHC.LanguageExtensions.Type +import Data.List + +parsePragmasIntoDynFlags :: DynFlags + -> ([Extension], [Extension]) + -> FilePath + -> String + -> IO (Either String DynFlags) +parsePragmasIntoDynFlags flags (enable, disable) file str = + catchErrors $ do + let opts = getOptions flags (stringToStringBuffer str) file + (flags, _, _) <- parseDynamicFilePragma flags opts + let flags' = foldl' xopt_set flags enable + let flags'' = foldl' xopt_unset flags' disable + return $ Right (flags'' `gopt_set` Opt_KeepRawTokenStream) + where + catchErrors :: IO (Either String DynFlags) -> IO (Either String DynFlags) + catchErrors act = handleGhcException reportErr + (handleSourceError reportErr act) + reportErr e = return $ Left (show e) diff --git a/src/Language/Haskell/GhclibParserEx/Fixity.hs b/src/Language/Haskell/GhclibParserEx/Fixity.hs --- a/src/Language/Haskell/GhclibParserEx/Fixity.hs +++ b/src/Language/Haskell/GhclibParserEx/Fixity.hs @@ -67,7 +67,7 @@ #if defined (GHCLIB_API_811) || defined (GHCLIB_API_810) | associate_right = ConPatIn op1 (InfixCon p11 (L loc (mkConOpPat fs op2 fix2 p12 p2))) #else - | associate_right = let new_p = mkConOpPat fs op2 fix2 p12 p2 in ConPatIn op1 (InfixCon p11 (cL loc new_p)) + | associate_right = ConPatIn op1 (InfixCon p11 (cL loc (mkConOpPat fs op2 fix2 p12 p2))) #endif | otherwise = ConPatIn op2 (InfixCon p1 p2) where @@ -109,7 +109,7 @@ getIdent (unLoc -> HsVar _ (L _ n)) = occNameString . rdrNameOcc $ n getIdent _ = error "Must be HsVar" --- If there are no fixities provided, give 'baseFixities. +-- If there are no fixities, give 'baseFixities'. getFixities :: [(String, Fixity)] -> [(String, Fixity)] getFixities fixities = if null fixities then baseFixities else fixities diff --git a/src/Language/Haskell/GhclibParserEx/HsExtendInstances.hs b/src/Language/Haskell/GhclibParserEx/HsExtendInstances.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/GhclibParserEx/HsExtendInstances.hs @@ -0,0 +1,50 @@ +-- Copyright (c) 2020, Shayne Fletcher. All rights reserved. +-- SPDX-License-Identifier: BSD-3-Clause. + +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +module Language.Haskell.GhclibParserEx.HsExtendInstances ( + 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. + +import Outputable +import Data.Data +import Data.Function + +import Language.Haskell.GhclibParserEx.Dump + +newtype HsExtendInstances a = + HsExtendInstances { unextendInstances :: a } + deriving Outputable + +extendInstances :: a -> HsExtendInstances a +extendInstances = HsExtendInstances + +-- Use 'showAstData'. This is preferable to 'ppr' in that trees that +-- only differ in arrangement due to fixities will produce differing +-- string representations. +toStr :: Data a => HsExtendInstances a -> String +toStr (HsExtendInstances e) = + Outputable.showSDocUnsafe $ showAstData BlankSrcSpan e + +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) = Outputable.showSDocUnsafe $ Outputable.ppr e diff --git a/src/Language/Haskell/GhclibParserEx/Parse.hs b/src/Language/Haskell/GhclibParserEx/Parse.hs --- a/src/Language/Haskell/GhclibParserEx/Parse.hs +++ b/src/Language/Haskell/GhclibParserEx/Parse.hs @@ -6,14 +6,21 @@ #include "ghclib_api.h" module Language.Haskell.GhclibParserEx.Parse( - parse - , parseExpr + parseFile + , parseModule + , parseSignature , parseImport + , parseStatement + , parseBackpack , parseDeclaration - , parseFile - , parsePragmasIntoDynFlags - , fakeSettings - , fakeLlvmConfig + , parseExpression + , parsePattern + , parseTypeSignature + , parseStmt + , parseIdentifier + , parseType + , parseHeader + , parse ) where @@ -23,76 +30,19 @@ #else import HsSyn #endif -import Config import DynFlags import StringBuffer -import Fingerprint import Lexer import qualified Parser import FastString import SrcLoc -import Panic -import HscTypes -import HeaderInfo - -#if defined (GHCLIB_API_811) || defined (GHCLIB_API_810) -import GHC.Platform -import ToolSettings -#else -import Platform -#endif - -fakeSettings :: Settings -fakeSettings = Settings -#if defined (GHCLIB_API_811) || defined (GHCLIB_API_810) - { sGhcNameVersion=ghcNameVersion - , sFileSettings=fileSettings - , sTargetPlatform=platform - , sPlatformMisc=platformMisc - , sPlatformConstants=platformConstants - , sToolSettings=toolSettings - } -#else - { sTargetPlatform=platform - , sPlatformConstants=platformConstants - , sProjectVersion=cProjectVersion - , sProgramName="ghc" - , sOpt_P_fingerprint=fingerprint0 - } -#endif - where -#if defined (GHCLIB_API_811) || defined (GHCLIB_API_810) - toolSettings = ToolSettings { - toolSettings_opt_P_fingerprint=fingerprint0 - } - fileSettings = FileSettings {} - platformMisc = PlatformMisc {} - ghcNameVersion = - GhcNameVersion{ghcNameVersion_programName="ghc" - ,ghcNameVersion_projectVersion=cProjectVersion - } -#endif - platform = - Platform{ -#if defined (GHCLIB_API_811) || defined (GHCLIB_API_810) - platformWordSize = PW8 - , platformMini = PlatformMini {platformMini_arch=ArchUnknown, platformMini_os=OSUnknown} -#else - platformWordSize=8 - , platformOS=OSUnknown -#endif - , platformUnregisterised=True - } - platformConstants = - PlatformConstants{pc_DYNAMIC_BY_DEFAULT=False,pc_WORD_SIZE=8} - -#if defined (GHCLIB_API_811) || defined (GHCLIB_API_810) -fakeLlvmConfig :: LlvmConfig -fakeLlvmConfig = LlvmConfig [] [] +import BkpSyn +#if defined (GHCLIB_API_811) +import UnitInfo #else -fakeLlvmConfig :: (LlvmTargets, LlvmPasses) -fakeLlvmConfig = ([], []) +import PackageConfig #endif +import RdrName parse :: P a -> String -> DynFlags -> ParseResult a parse p str flags = @@ -103,19 +53,61 @@ parseState = mkPState flags buffer location #if defined (GHCLIB_API_811) -parseExpr :: String -> DynFlags -> ParseResult RdrHsSyn.ECP +parseModule :: String -> DynFlags -> ParseResult (Located HsModule) #else -parseExpr :: String -> DynFlags -> ParseResult (LHsExpr GhcPs) +parseModule :: String -> DynFlags -> ParseResult (Located (HsModule GhcPs)) #endif -parseExpr = parse Parser.parseExpression +parseModule = parse Parser.parseModule +#if defined (GHCLIB_API_811) +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 -#if defined (GHC_API_811) +#if defined (GHCLIB_API_811) +parseExpression :: String -> DynFlags -> ParseResult RdrHsSyn.ECP +#else +parseExpression :: String -> DynFlags -> ParseResult (LHsExpr GhcPs) +#endif +parseExpression = parse Parser.parseExpression + +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 + +parseIdentifier :: String -> DynFlags -> ParseResult (Located RdrName) +parseIdentifier = parse Parser.parseIdentifier + +parseType :: String -> DynFlags -> ParseResult (LHsType GhcPs) +parseType = parse Parser.parseType + +#if defined(GHCLIB_API_811) +parseHeader :: String -> DynFlags -> ParseResult (Located HsModule) +#else +parseHeader :: String -> DynFlags -> ParseResult (Located (HsModule GhcPs)) +#endif +parseHeader = parse Parser.parseHeader + +#if defined (GHCLIB_API_811) parseFile :: String -> DynFlags -> String @@ -132,18 +124,3 @@ location = mkRealSrcLoc (mkFastString filename) 1 1 buffer = stringToStringBuffer str parseState = mkPState flags buffer location - -parsePragmasIntoDynFlags :: DynFlags - -> FilePath - -> String - -> IO (Either String DynFlags) -parsePragmasIntoDynFlags flags file str = - catchErrors $ do - let opts = getOptions flags (stringToStringBuffer str) file - (flags, _, _) <- parseDynamicFilePragma flags opts - return $ Right (flags `gopt_set` Opt_KeepRawTokenStream) - where - catchErrors :: IO (Either String DynFlags) -> IO (Either String DynFlags) - catchErrors act = handleGhcException reportErr - (handleSourceError reportErr act) - reportErr e = return $ Left (show e) diff --git a/test/Test.hs b/test/Test.hs --- a/test/Test.hs +++ b/test/Test.hs @@ -13,20 +13,21 @@ import System.IO.Extra import Control.Monad +import Language.Haskell.GhclibParserEx.Config +import Language.Haskell.GhclibParserEx.DynFlags +import Language.Haskell.GhclibParserEx.HsExtendInstances import Language.Haskell.GhclibParserEx.Parse import Language.Haskell.GhclibParserEx.Dump import Language.Haskell.GhclibParserEx.Fixity #if defined (GHCLIB_API_811) || defined (GHCLIB_API_810) import GHC.Hs -#else -import HsSyn +import RdrHsSyn #endif import DynFlags import Lexer import Outputable import ErrUtils -import RdrHsSyn #if defined (GHCLIB_API_808) import Bag #endif @@ -38,7 +39,7 @@ defaultMain tests tests :: TestTree -tests = testGroup " All tests" [parseTests, fixityTests] +tests = testGroup " All tests" [parseTests, fixityTests, extendInstancesTests] chkParseResult :: (DynFlags -> WarningMessages -> String) -> DynFlags -> ParseResult a -> IO () chkParseResult report flags = \case @@ -55,36 +56,59 @@ parseTests :: TestTree parseTests = testGroup "Parse tests" [ - testCase "Expression" $ do - let flags = defaultDynFlags fakeSettings fakeLlvmConfig + testCase "Module" $ chkParseResult report flags $ - parseExpr "unfoldr $ listToMaybe . concatMap reads . tails" flags - , testCase "Import" $ do - let flags = defaultDynFlags fakeSettings fakeLlvmConfig + parseModule (unlines + [ "module Foo (readMany) where" + , "import Data.List" + , "import Data.Maybe" + , "readMany = unfoldr $ listToMaybe . concatMap reads . tails" + ]) flags + , testCase "Signature" $ chkParseResult report flags $ + parseSignature (unlines + [ "signature Str where" + , "data Str" + , "empty :: Str" + , "append :: Str -> Str -> Str" + ]) flags + , testCase "Import" $ + chkParseResult report flags $ parseImport "import qualified \"foo-lib\" Foo as Bar hiding ((<.>))" flags - , testCase "Declaration" $ do - let flags = defaultDynFlags fakeSettings fakeLlvmConfig + , testCase "Statement" $ chkParseResult report flags $ - parseDeclaration ( - unlines [ - "fact :: Int -> Int" - , "fact n = if n <= 1 then 1 else n * fact (n - 1)" - ]) flags + parseStatement "Foo foo <- bar" flags + , testCase "Backpack" $ + chkParseResult report flags $ + parseBackpack (unlines + [ "unit main where" + , " module Main where" + , " main = putStrLn \"Hello world!\"" + ]) flags + , testCase "Expression" $ + chkParseResult report flags $ + parseExpression "unfoldr $ listToMaybe . concatMap reads . tails" flags + , testCase "Declaration (1)" $ + chkParseResult report 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 report flags $ + parseDeclaration "infixr 4 <%@~" flags , testCase "File" $ do foo <- makeFile "Foo.hs" $ unlines - [ "module Foo (readMany) where" + ["{-# LANGUAGE ScopedTypeVariables #-}" + , "module Foo (readMany) where" , "import Data.List" , "import Data.Maybe" , "readMany = unfoldr $ listToMaybe . concatMap reads . tails" ] s <- readFile' foo - parsePragmasIntoDynFlags (defaultDynFlags fakeSettings fakeLlvmConfig) foo s >>= \case + parsePragmasIntoDynFlags flags ([], []) foo s >>= \case Left msg -> assertFailure msg - Right flags -> - chkParseResult report flags $ parseFile foo (flags `gopt_set` Opt_KeepRawTokenStream) s + Right flags -> chkParseResult report flags $ parseFile foo flags s ] where + flags = unsafeGlobalDynFlags report flags msgs = concat [ showSDoc flags msg | msg <- pprErrMsgBagWithLoc msgs ] fixityTests :: TestTree @@ -92,8 +116,12 @@ [ testCase "Expression" $ do let flags = defaultDynFlags fakeSettings fakeLlvmConfig - case parseExpr "1 + 2 * 3" flags of + case parseExpression "1 + 2 * 3" flags of +#if defined (GHCLIB_API_811) || defined (GHCLIB_API_810) POk s e -> +#else + POk _ e -> +#endif #if defined (GHCLIB_API_811) || defined (GHCLIB_API_810) case unP (runECP_P e >>= \e -> return e) s :: ParseResult (LHsExpr GhcPs) of POk _ e -> @@ -120,3 +148,34 @@ Directory.createDirectoryIfMissing True $ FilePath.takeDirectory relPath writeFile relPath contents return relPath + +extendInstancesTests :: TestTree +extendInstancesTests = testGroup "Extend instances tests" + [ + testCase "Eq, Ord" $ do + let flags = defaultDynFlags fakeSettings fakeLlvmConfig + case parseExpression "1 + 2 * 3" flags of +#if defined (GHCLIB_API_811) || defined (GHCLIB_API_810) + POk s e -> +#else + POk _ e -> +#endif +#if defined (GHCLIB_API_811) || defined (GHCLIB_API_810) + case unP (runECP_P e >>= \e -> return e) s :: ParseResult (LHsExpr GhcPs) of + POk _ e -> +#endif + 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' +#if defined (GHCLIB_API_811) || defined (GHCLIB_API_810) + _ -> assertFailure "ecp failure" +#endif + _ -> assertFailure "parse error" + ]