diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,6 +1,50 @@ # Changelog for ghc-lib-parser-ex -## Unreleased changes +## 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 diff --git a/cbits/ghclib_api.h b/cbits/ghclib_api.h --- a/cbits/ghclib_api.h +++ b/cbits/ghclib_api.h @@ -11,7 +11,7 @@ # if !MIN_VERSION_ghc_lib_parser(1, 0, 0) # define GHCLIB_API_811 # elif MIN_VERSION_ghc_lib_parser(8, 10, 0) -# define GHCLIBAPI_810 +# define GHCLIB_API_810 # elif MIN_VERSION_ghc_lib_parser(8, 8, 0) # define GHCLIB_API_808 # else 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.20200301 +version: 0.20200401 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 @@ -22,17 +22,23 @@ type: git location: https://github.com/shayne-fletcher/ghc-lib-parser-ex -flag ghc-lib +flag auto + default: True + manual: True + description: Used default configuration + +flag no-ghc-lib default: False manual: True - description: Force dependency on ghc-lib-parser even if GHC API in the ghc package is supported + description: Force dependency on native ghc-libs library exposed-modules: Language.Haskell.GhclibParserEx.Config Language.Haskell.GhclibParserEx.Dump - Language.Haskell.GhclibParserEx.DynFlags Language.Haskell.GhclibParserEx.Fixity + Language.Haskell.GhclibParserEx.GHC.Driver.Flags + Language.Haskell.GhclibParserEx.GHC.Driver.Session Language.Haskell.GhclibParserEx.GHC.Hs.Expr Language.Haskell.GhclibParserEx.GHC.Hs.Pat Language.Haskell.GhclibParserEx.GHC.Hs.Types @@ -48,16 +54,25 @@ base >=4.7 && <5, uniplate >= 1.5, bytestring >= 0.10.8.2, - containers >= 0.5.8.1, - extra >= 1.6.19 - if !flag(ghc-lib) && impl(ghc >= 8.8.0) && impl(ghc < 8.9.0) - build-depends: - ghc == 8.8.*, - ghc-boot-th, - ghc-boot + containers >= 0.5.8.1 + if flag(auto) && impl(ghc >= 8.10.0) && impl(ghc < 8.11.0) + build-depends: + ghc == 8.10.*, + ghc-boot-th, + ghc-boot else + if flag(auto) build-depends: - ghc-lib-parser + ghc-lib-parser == 8.10.* + else + if flag(no-ghc-lib) + build-depends: + ghc, + ghc-boot-th, + ghc-boot + else + build-depends: + ghc-lib-parser include-dirs: cbits install-includes: @@ -83,11 +98,22 @@ , filepath >= 1.4.2 , extra >=1.6 , ghc-lib-parser-ex - if !flag(ghc-lib) && impl(ghc >= 8.8.0) && impl(ghc < 8.9.0) - build-depends: - ghc == 8.8.*, - ghc-boot-th + if flag(auto) && impl(ghc >= 8.10.0) && impl(ghc < 8.11.0) + build-depends: + ghc == 8.10.*, + ghc-boot-th, + ghc-boot else + if flag(auto) build-depends: - ghc-lib-parser + ghc-lib-parser == 8.10.* + else + if flag(no-ghc-lib) + build-depends: + ghc, + ghc-boot-th, + ghc-boot + else + build-depends: + ghc-lib-parser default-language: Haskell2010 diff --git a/src/Language/Haskell/GhclibParserEx/DynFlags.hs b/src/Language/Haskell/GhclibParserEx/DynFlags.hs deleted file mode 100644 --- a/src/Language/Haskell/GhclibParserEx/DynFlags.hs +++ /dev/null @@ -1,155 +0,0 @@ --- Copyright (c) 2020, Shayne Fletcher. All rights reserved. --- SPDX-License-Identifier: BSD-3-Clause. - -{-# LANGUAGE CPP #-} -#include "ghclib_api.h" - -module Language.Haskell.GhclibParserEx.DynFlags( - readExtension - , extensionImplications - -- Copied from DynFlags (see - -- https://gitlab.haskell.org/ghc/ghc/merge_requests/2654). - , TurnOnFlag, turnOn, turnOff, impliedGFlags, impliedOffGFlags, impliedXFlags - -- - , parsePragmasIntoDynFlags - ) where - -import qualified GHC.LanguageExtensions as LangExt -import Panic -import HeaderInfo -import StringBuffer -#if defined(GHCLIB_API_811) -import GHC.Driver.Session -import GHC.Driver.Types -#else -import DynFlags -import HscTypes -#endif -import GHC.LanguageExtensions.Type -import Data.List -import Data.List.Extra -import Data.Maybe -import qualified Data.Map as Map - --- | Parse a GHC extension. -readExtension :: String -> Maybe Extension -readExtension = (`Map.lookup` exts) - where exts = Map.fromList [(show x, x) | x <- enumerate] - --- | 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] - --- Copied from 'ghc/compiler/main/DynFlags.hs'. - -type TurnOnFlag = Bool -- True <=> we are turning the flag on - -- False <=> we are turning the flag off -turnOn :: TurnOnFlag; turnOn = True -turnOff :: TurnOnFlag; turnOff = False - --- General flags that are switched on/off when other general flags are switched --- on -impliedGFlags :: [(GeneralFlag, TurnOnFlag, GeneralFlag)] -impliedGFlags = [(Opt_DeferTypeErrors, turnOn, Opt_DeferTypedHoles) - ,(Opt_DeferTypeErrors, turnOn, Opt_DeferOutOfScopeVariables) - ,(Opt_Strictness, turnOn, Opt_WorkerWrapper) - ,(Opt_UnclutterValidHoleFits, turnOff, Opt_ShowTypeAppOfHoleFits) - ,(Opt_UnclutterValidHoleFits, turnOff, Opt_ShowTypeAppVarsOfHoleFits) - ,(Opt_UnclutterValidHoleFits, turnOff, Opt_ShowDocsOfHoleFits) - ,(Opt_ShowTypeAppVarsOfHoleFits, turnOff, Opt_ShowTypeAppOfHoleFits) - ,(Opt_UnclutterValidHoleFits, turnOff, Opt_ShowProvOfHoleFits)] - --- General flags that are switched on/off when other general flags are switched --- off -impliedOffGFlags :: [(GeneralFlag, TurnOnFlag, GeneralFlag)] -impliedOffGFlags = [(Opt_Strictness, turnOff, Opt_WorkerWrapper)] - -impliedXFlags :: [(LangExt.Extension, TurnOnFlag, LangExt.Extension)] -impliedXFlags --- See Note [Updating flag description in the User's Guide] - = [ (LangExt.RankNTypes, turnOn, LangExt.ExplicitForAll) - , (LangExt.QuantifiedConstraints, turnOn, LangExt.ExplicitForAll) - , (LangExt.ScopedTypeVariables, turnOn, LangExt.ExplicitForAll) - , (LangExt.LiberalTypeSynonyms, turnOn, LangExt.ExplicitForAll) - , (LangExt.ExistentialQuantification, turnOn, LangExt.ExplicitForAll) - , (LangExt.FlexibleInstances, turnOn, LangExt.TypeSynonymInstances) - , (LangExt.FunctionalDependencies, turnOn, LangExt.MultiParamTypeClasses) - , (LangExt.MultiParamTypeClasses, turnOn, LangExt.ConstrainedClassMethods) -- c.f. #7854 - , (LangExt.TypeFamilyDependencies, turnOn, LangExt.TypeFamilies) - - , (LangExt.RebindableSyntax, turnOff, LangExt.ImplicitPrelude) -- NB: turn off! - - , (LangExt.DerivingVia, turnOn, LangExt.DerivingStrategies) - - , (LangExt.GADTs, turnOn, LangExt.GADTSyntax) - , (LangExt.GADTs, turnOn, LangExt.MonoLocalBinds) - , (LangExt.TypeFamilies, turnOn, LangExt.MonoLocalBinds) - - , (LangExt.TypeFamilies, turnOn, LangExt.KindSignatures) -- Type families use kind signatures - , (LangExt.PolyKinds, turnOn, LangExt.KindSignatures) -- Ditto polymorphic kinds - - -- TypeInType is now just a synonym for a couple of other extensions. - , (LangExt.TypeInType, turnOn, LangExt.DataKinds) - , (LangExt.TypeInType, turnOn, LangExt.PolyKinds) - , (LangExt.TypeInType, turnOn, LangExt.KindSignatures) - -#if defined(GHCLIB_API_811) || defined(GHCLIB_API_810) - -- Standalone kind signatures are a replacement for CUSKs. - , (LangExt.StandaloneKindSignatures, turnOff, LangExt.CUSKs) -#endif - - -- AutoDeriveTypeable is not very useful without DeriveDataTypeable - , (LangExt.AutoDeriveTypeable, turnOn, LangExt.DeriveDataTypeable) - - -- We turn this on so that we can export associated type - -- type synonyms in subordinates (e.g. MyClass(type AssocType)) - , (LangExt.TypeFamilies, turnOn, LangExt.ExplicitNamespaces) - , (LangExt.TypeOperators, turnOn, LangExt.ExplicitNamespaces) - - , (LangExt.ImpredicativeTypes, turnOn, LangExt.RankNTypes) - - -- Record wild-cards implies field disambiguation - -- Otherwise if you write (C {..}) you may well get - -- stuff like " 'a' not in scope ", which is a bit silly - -- if the compiler has just filled in field 'a' of constructor 'C' - , (LangExt.RecordWildCards, turnOn, LangExt.DisambiguateRecordFields) - - , (LangExt.ParallelArrays, turnOn, LangExt.ParallelListComp) - - , (LangExt.JavaScriptFFI, turnOn, LangExt.InterruptibleFFI) - - , (LangExt.DeriveTraversable, turnOn, LangExt.DeriveFunctor) - , (LangExt.DeriveTraversable, turnOn, LangExt.DeriveFoldable) - - -- Duplicate record fields require field disambiguation - , (LangExt.DuplicateRecordFields, turnOn, LangExt.DisambiguateRecordFields) - - , (LangExt.TemplateHaskell, turnOn, LangExt.TemplateHaskellQuotes) - , (LangExt.Strict, turnOn, LangExt.StrictData) - ] - --- - -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 @@ -9,17 +9,37 @@ {-# LANGUAGE TupleSections #-} #include "ghclib_api.h" -module Language.Haskell.GhclibParserEx.Fixity(applyFixities) where +module Language.Haskell.GhclibParserEx.Fixity( + applyFixities + , preludeFixities, baseFixities + , infixr_, infixl_, infix_, fixity + ) where +#if defined (GHCLIB_API_811) +import GHC.Types.Basic +#else import BasicTypes +#endif #if defined (GHCLIB_API_811) || defined (GHCLIB_API_810) import GHC.Hs #else import HsSyn #endif +#if defined (GHCLIB_API_811) +import GHC.Types.Name.Reader +#else import RdrName +#endif +#if defined (GHCLIB_API_811) +import GHC.Types.Name +#else import OccName +#endif +#if defined (GHCLIB_API_811) +import GHC.Types.SrcLoc +#else import SrcLoc +#endif import Data.Maybe import Data.Data hiding (Fixity) import Data.Generics.Uniplate.Data @@ -146,16 +166,18 @@ -- this list is that of Control.Arrows. baseFixities :: [(String, Fixity)] baseFixities = preludeFixities ++ concat - [ infixl_ 9 ["!","//","!:"] + [ 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. + , infixr_ 5 ["+:+","<++","<+>","<|"] -- Fixity conflict for +++ between ReadP and Arrow. , infix_ 5 ["\\\\"] - , infixl_ 4 ["<$>","<$","<*>","<*","*>","<**>"] - , infix_ 4 ["elemP","notElemP"] + , infixl_ 4 ["<$>","<$","$>","<*>","<*","*>","<**>","<$!>"] + , infix_ 4 ["elemP","notElemP",":~:", ":~~:"] , infixl_ 3 ["<|>"] , infixr_ 3 ["&&&","***"] , infixr_ 2 ["+++","|||"] diff --git a/src/Language/Haskell/GhclibParserEx/GHC/Driver/Flags.hs b/src/Language/Haskell/GhclibParserEx/GHC/Driver/Flags.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/GhclibParserEx/GHC/Driver/Flags.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -Wno-orphans #-} +#include "ghclib_api.h" +module Language.Haskell.GhclibParserEx.GHC.Driver.Flags () where + +#if defined(GHCLIB_API_811) +import GHC.Driver.Session +#else +import DynFlags +#endif + +-- Oprhan instance until +-- https://gitlab.haskell.org/ghc/ghc/merge_requests/2905 lands. +instance Bounded Language where + minBound = Haskell98 + maxBound = Haskell2010 diff --git a/src/Language/Haskell/GhclibParserEx/GHC/Driver/Session.hs b/src/Language/Haskell/GhclibParserEx/GHC/Driver/Session.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/GhclibParserEx/GHC/Driver/Session.hs @@ -0,0 +1,160 @@ +-- Copyright (c) 2020, Shayne Fletcher. All rights reserved. +-- SPDX-License-Identifier: BSD-3-Clause. + +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -Wno-orphans #-} +#include "ghclib_api.h" + +module Language.Haskell.GhclibParserEx.GHC.Driver.Session( + readExtension + , extensionImplications + -- Copied from DynFlags (see + -- https://gitlab.haskell.org/ghc/ghc/merge_requests/2654). + , TurnOnFlag, turnOn, turnOff, impliedGFlags, impliedOffGFlags, impliedXFlags + -- + , parsePragmasIntoDynFlags + ) where + +import qualified GHC.LanguageExtensions as LangExt +import Panic +import HeaderInfo +import StringBuffer +#if defined(GHCLIB_API_811) +import GHC.Driver.Session +import GHC.Driver.Types +#else +import DynFlags +import HscTypes +#endif +import GHC.LanguageExtensions.Type +import Data.List +import Data.Maybe +import Data.Function +import qualified Data.Map as Map + +-- Oprhan instance until +-- https://gitlab.haskell.org/ghc/ghc/merge_requests/2707 lands. +instance Ord Extension where + compare = compare `on` fromEnum + +-- | Parse a GHC extension. +readExtension :: String -> Maybe Extension +readExtension s = flagSpecFlag <$> find (\(FlagSpec n _ _ _) -> n == s) xFlags + +-- | Implicitly enabled/disabled extensions. +extensionImplications :: [(Extension, ([Extension], [Extension]))] +extensionImplications = map f $ Map.toList implicationsMap + where + f (e, ps) = (fromJust (readExtension e), ps) + implicationsMap :: Map.Map String ([Extension], [Extension]) + implicationsMap = Map.fromListWith (<>) + [(show a, ([c | b], [c | not b])) + | (a, flag, c) <- impliedXFlags, let b = flag == turnOn] + +-- Copied from 'ghc/compiler/main/DynFlags.hs'. + +type TurnOnFlag = Bool -- True <=> we are turning the flag on + -- False <=> we are turning the flag off +turnOn :: TurnOnFlag; turnOn = True +turnOff :: TurnOnFlag; turnOff = False + +-- General flags that are switched on/off when other general flags are switched +-- on +impliedGFlags :: [(GeneralFlag, TurnOnFlag, GeneralFlag)] +impliedGFlags = [(Opt_DeferTypeErrors, turnOn, Opt_DeferTypedHoles) + ,(Opt_DeferTypeErrors, turnOn, Opt_DeferOutOfScopeVariables) + ,(Opt_Strictness, turnOn, Opt_WorkerWrapper) + ,(Opt_UnclutterValidHoleFits, turnOff, Opt_ShowTypeAppOfHoleFits) + ,(Opt_UnclutterValidHoleFits, turnOff, Opt_ShowTypeAppVarsOfHoleFits) + ,(Opt_UnclutterValidHoleFits, turnOff, Opt_ShowDocsOfHoleFits) + ,(Opt_ShowTypeAppVarsOfHoleFits, turnOff, Opt_ShowTypeAppOfHoleFits) + ,(Opt_UnclutterValidHoleFits, turnOff, Opt_ShowProvOfHoleFits)] + +-- General flags that are switched on/off when other general flags are switched +-- off +impliedOffGFlags :: [(GeneralFlag, TurnOnFlag, GeneralFlag)] +impliedOffGFlags = [(Opt_Strictness, turnOff, Opt_WorkerWrapper)] + +impliedXFlags :: [(LangExt.Extension, TurnOnFlag, LangExt.Extension)] +impliedXFlags +-- See Note [Updating flag description in the User's Guide] + = [ (LangExt.RankNTypes, turnOn, LangExt.ExplicitForAll) + , (LangExt.QuantifiedConstraints, turnOn, LangExt.ExplicitForAll) + , (LangExt.ScopedTypeVariables, turnOn, LangExt.ExplicitForAll) + , (LangExt.LiberalTypeSynonyms, turnOn, LangExt.ExplicitForAll) + , (LangExt.ExistentialQuantification, turnOn, LangExt.ExplicitForAll) + , (LangExt.FlexibleInstances, turnOn, LangExt.TypeSynonymInstances) + , (LangExt.FunctionalDependencies, turnOn, LangExt.MultiParamTypeClasses) + , (LangExt.MultiParamTypeClasses, turnOn, LangExt.ConstrainedClassMethods) -- c.f. #7854 + , (LangExt.TypeFamilyDependencies, turnOn, LangExt.TypeFamilies) + + , (LangExt.RebindableSyntax, turnOff, LangExt.ImplicitPrelude) -- NB: turn off! + + , (LangExt.DerivingVia, turnOn, LangExt.DerivingStrategies) + + , (LangExt.GADTs, turnOn, LangExt.GADTSyntax) + , (LangExt.GADTs, turnOn, LangExt.MonoLocalBinds) + , (LangExt.TypeFamilies, turnOn, LangExt.MonoLocalBinds) + + , (LangExt.TypeFamilies, turnOn, LangExt.KindSignatures) -- Type families use kind signatures + , (LangExt.PolyKinds, turnOn, LangExt.KindSignatures) -- Ditto polymorphic kinds + + -- TypeInType is now just a synonym for a couple of other extensions. + , (LangExt.TypeInType, turnOn, LangExt.DataKinds) + , (LangExt.TypeInType, turnOn, LangExt.PolyKinds) + , (LangExt.TypeInType, turnOn, LangExt.KindSignatures) + +#if defined(GHCLIB_API_811) || defined(GHCLIB_API_810) + -- Standalone kind signatures are a replacement for CUSKs. + , (LangExt.StandaloneKindSignatures, turnOff, LangExt.CUSKs) +#endif + + -- AutoDeriveTypeable is not very useful without DeriveDataTypeable + , (LangExt.AutoDeriveTypeable, turnOn, LangExt.DeriveDataTypeable) + + -- We turn this on so that we can export associated type + -- type synonyms in subordinates (e.g. MyClass(type AssocType)) + , (LangExt.TypeFamilies, turnOn, LangExt.ExplicitNamespaces) + , (LangExt.TypeOperators, turnOn, LangExt.ExplicitNamespaces) + + , (LangExt.ImpredicativeTypes, turnOn, LangExt.RankNTypes) + + -- Record wild-cards implies field disambiguation + -- Otherwise if you write (C {..}) you may well get + -- stuff like " 'a' not in scope ", which is a bit silly + -- if the compiler has just filled in field 'a' of constructor 'C' + , (LangExt.RecordWildCards, turnOn, LangExt.DisambiguateRecordFields) + + , (LangExt.ParallelArrays, turnOn, LangExt.ParallelListComp) + + , (LangExt.JavaScriptFFI, turnOn, LangExt.InterruptibleFFI) + + , (LangExt.DeriveTraversable, turnOn, LangExt.DeriveFunctor) + , (LangExt.DeriveTraversable, turnOn, LangExt.DeriveFoldable) + + -- Duplicate record fields require field disambiguation + , (LangExt.DuplicateRecordFields, turnOn, LangExt.DisambiguateRecordFields) + + , (LangExt.TemplateHaskell, turnOn, LangExt.TemplateHaskellQuotes) + , (LangExt.Strict, turnOn, LangExt.StrictData) + ] + +-- + +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/GHC/Hs/Decls.hs b/src/Language/Haskell/GhclibParserEx/GHC/Hs/Decls.hs --- a/src/Language/Haskell/GhclibParserEx/GHC/Hs/Decls.hs +++ b/src/Language/Haskell/GhclibParserEx/GHC/Hs/Decls.hs @@ -12,7 +12,11 @@ #else import HsSyn #endif +#if defined (GHCLIB_API_811) +import GHC.Types.SrcLoc +#else import SrcLoc +#endif isNewType :: NewOrData -> Bool isNewType NewType = True diff --git a/src/Language/Haskell/GhclibParserEx/GHC/Hs/Expr.hs b/src/Language/Haskell/GhclibParserEx/GHC/Hs/Expr.hs --- a/src/Language/Haskell/GhclibParserEx/GHC/Hs/Expr.hs +++ b/src/Language/Haskell/GhclibParserEx/GHC/Hs/Expr.hs @@ -22,11 +22,27 @@ #else import HsSyn #endif +#if defined (GHCLIB_API_811) +import GHC.Types.SrcLoc +#else import SrcLoc +#endif +#if defined (GHCLIB_API_811) +import GHC.Types.Name.Reader +#else import RdrName +#endif +#if defined (GHCLIB_API_811) +import GHC.Types.Name +#else import OccName import Name +#endif +#if defined (GHCLIB_API_811) +import GHC.Types.Basic +#else import BasicTypes +#endif import TysWiredIn -- 'True' if the provided expression is a variable with name 'tag'. @@ -108,8 +124,10 @@ -- Field has a '_' as in '{foo=_} or is punned e.g. '{foo}'. isFieldWildcard :: LHsRecField GhcPs (LHsExpr GhcPs) -> Bool isFieldWildcard = \case -#if defined (GHCLIB_API_811) || defined (GHCLIB_API_810) +#if defined (GHCLIB_API_811) (L _ HsRecField {hsRecFieldArg=(L _ (HsUnboundVar _ s))}) -> occNameString s == "_" +#elif defined (GHCLIB_API_810) + (L _ HsRecField {hsRecFieldArg=(L _ (HsUnboundVar _ _))}) -> True #else (L _ HsRecField {hsRecFieldArg=(L _ (EWildPat _))}) -> True #endif diff --git a/src/Language/Haskell/GhclibParserEx/GHC/Hs/Pat.hs b/src/Language/Haskell/GhclibParserEx/GHC/Hs/Pat.hs --- a/src/Language/Haskell/GhclibParserEx/GHC/Hs/Pat.hs +++ b/src/Language/Haskell/GhclibParserEx/GHC/Hs/Pat.hs @@ -16,10 +16,19 @@ #else import HsSyn #endif +#if defined (GHCLIB_API_811) +import GHC.Types.SrcLoc +#else import SrcLoc +#endif import TysWiredIn +#if defined (GHCLIB_API_811) +import GHC.Types.Name.Reader +import GHC.Types.Name +#else import RdrName import OccName +#endif import FastString patToStr :: LPat GhcPs -> String @@ -56,18 +65,18 @@ fromPChar _ = Nothing -- Contains a '..' as in 'Foo{..}' -hasPFieldsDotDot :: HsRecFields GhcPs (Pat GhcPs) -> Bool +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}'. -isPFieldWildcard :: LHsRecField GhcPs (Pat GhcPs) -> Bool +isPFieldWildcard :: LHsRecField GhcPs (LPat GhcPs) -> Bool #if defined (GHCLIB_API_811) || defined (GHCLIB_API_810) -isPFieldWildcard (L _ HsRecField {hsRecFieldArg=WildPat _}) = True +isPFieldWildcard (L _ HsRecField {hsRecFieldArg=L _ WildPat {}}) = True isPFieldWildcard (L _ HsRecField {hsRecPun=True}) = True isPFieldWildcard (L _ HsRecField {}) = False #else -isPFieldWildcard (dL -> L _ HsRecField {hsRecFieldArg=WildPat _}) = True +isPFieldWildcard (dL -> L _ HsRecField {hsRecFieldArg=LL _ WildPat {}}) = True isPFieldWildcard (dL -> L _ HsRecField {hsRecPun=True}) = True isPFieldWildcard (dL -> L _ HsRecField {}) = False #endif diff --git a/src/Language/Haskell/GhclibParserEx/GHC/Hs/Types.hs b/src/Language/Haskell/GhclibParserEx/GHC/Hs/Types.hs --- a/src/Language/Haskell/GhclibParserEx/GHC/Hs/Types.hs +++ b/src/Language/Haskell/GhclibParserEx/GHC/Hs/Types.hs @@ -13,7 +13,11 @@ #else import HsSyn #endif +#if defined (GHCLIB_API_811) +import GHC.Types.SrcLoc +#else import SrcLoc +#endif fromTyParen :: LHsType GhcPs -> LHsType GhcPs fromTyParen (L _ (HsParTy _ x)) = x 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 @@ -39,7 +39,11 @@ import Lexer import qualified Parser import FastString +#if defined (GHCLIB_API_811) +import GHC.Types.SrcLoc +#else import SrcLoc +#endif #if defined (GHCLIB_API_811) import GHC.Driver.Backpack.Syntax #else @@ -50,7 +54,11 @@ #else import PackageConfig #endif +#if defined (GHCLIB_API_811) +import GHC.Types.Name.Reader +#else import RdrName +#endif parse :: P a -> String -> DynFlags -> ParseResult a parse p str flags = @@ -86,7 +94,7 @@ parseDeclaration :: String -> DynFlags -> ParseResult (LHsDecl GhcPs) parseDeclaration = parse Parser.parseDeclaration -#if defined (GHCLIB_API_811) +#if defined (GHCLIB_API_811) || defined (GHCLIB_API_810) parseExpression :: String -> DynFlags -> ParseResult RdrHsSyn.ECP #else parseExpression :: String -> DynFlags -> ParseResult (LHsExpr GhcPs) diff --git a/test/Test.hs b/test/Test.hs --- a/test/Test.hs +++ b/test/Test.hs @@ -3,6 +3,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TypeApplications #-} #include "ghclib_api.h" import Test.Tasty @@ -13,17 +14,18 @@ import qualified System.FilePath as FilePath import System.IO.Extra import Control.Monad -import Data.List +import Data.List.Extra import Data.Maybe import Language.Haskell.GhclibParserEx.Config -import Language.Haskell.GhclibParserEx.DynFlags import Language.Haskell.GhclibParserEx.Parse import Language.Haskell.GhclibParserEx.Dump import Language.Haskell.GhclibParserEx.Fixity 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.Driver.Flags() +import Language.Haskell.GhclibParserEx.GHC.Driver.Session #if defined (GHCLIB_API_811) || defined (GHCLIB_API_810) import GHC.Hs @@ -31,7 +33,11 @@ #else import HsSyn #endif +#if defined (GHCLIB_API_811) +import GHC.Types.SrcLoc +#else import SrcLoc +#endif #if defined (GHCLIB_API_811) import GHC.Driver.Session #else @@ -235,7 +241,7 @@ , testCase "isDotApp" $ test "f . g" $ assert' . isDotApp , testCase "isDotApp" $ test "f $ g" $ assert' . not . isDotApp , testCase "isTypeApp" $ test "f @Int" $ assert' . isTypeApp -#if defined (GHCLIB_API_808) +#if defined (GHCLIB_API_808) || defined (GHCLIB_API_810) , testCase "isTypeApp" $ test "f @ Int" $ assert' . isTypeApp #else , testCase "isTypeApp" $ test "f @ Int" $ assert' . not . isTypeApp @@ -299,4 +305,6 @@ 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 instace Ord Extension" $ assertBool "minBound >= maxBound" (minBound @Extension < maxBound @Extension) ]