diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,9 @@ # Revision history for large-records +## 0.4.3 -- 2025-07-19 + +* Support ghc 9.8 (Gabriele Sales) + ## 0.4.2 -- 2024-10-15 * Support `primitive-0.7.3` (#159, Isaac Elliott). diff --git a/large-records.cabal b/large-records.cabal --- a/large-records.cabal +++ b/large-records.cabal @@ -1,6 +1,6 @@ cabal-version: 2.4 name: large-records -version: 0.4.2 +version: 0.4.3 synopsis: Efficient compilation for large records, linear in the size of the record description: For many reasons, the internal code generated for modules that contain records is quadratic in the number of record @@ -16,7 +16,11 @@ maintainer: edsko@well-typed.com category: Generics extra-doc-files: CHANGELOG.md -tested-with: GHC ==8.10.7 || ==9.2.8 || ==9.4.8 || ==9.6.6 +tested-with: GHC ==8.10.7 + GHC ==9.2.8 + GHC ==9.4.8 + GHC ==9.6.7 + GHC ==9.8.4 source-repository head type: git @@ -44,14 +48,14 @@ Data.Record.Internal.Plugin.Record build-depends: - , base >= 4.14 && < 4.19 - , containers >= 0.6.2 && < 0.8 - , ghc >= 8.10 && < 9.7 + , base >= 4.14 && < 4.20 + , containers >= 0.6.2 && < 0.9 + , ghc >= 8.10 && < 9.9 , mtl >= 2.2.1 && < 2.4 , primitive >= 0.7.3 && < 0.10 , record-hasfield >= 1.0 && < 1.1 , syb >= 0.7 && < 0.8 - , template-haskell >= 2.16 && < 2.21 + , template-haskell >= 2.16 && < 2.22 -- large-generics 0.2 starts using 'SmallArray' instead of 'Vector' , large-generics >= 0.2 && < 0.3 @@ -70,15 +74,13 @@ ghc-options: -Wall -Wcompat - -Wincomplete-uni-patterns + -Widentities -Wincomplete-record-updates + -Wincomplete-uni-patterns + -Wmissing-export-lists -Wpartial-fields - -Widentities -Wredundant-constraints - -Wmissing-export-lists - - if impl(ghc >= 8.10) - ghc-options: -Wunused-packages + -Wunused-packages test-suite test-large-records type: diff --git a/src/Data/Record/Internal/GHC/Shim.hs b/src/Data/Record/Internal/GHC/Shim.hs --- a/src/Data/Record/Internal/GHC/Shim.hs +++ b/src/Data/Record/Internal/GHC/Shim.hs @@ -67,6 +67,10 @@ -- * Records , simpleRecordUpdates + -- * Diagnostics + , issueError + , issueWarning + -- * Re-exports -- The whole-sale module exports are not ideal for preserving compatibility @@ -141,6 +145,9 @@ #if __GLASGOW_HASKELL__ < 904 , trace #endif +#if __GLASGOW_HASKELL__ >= 908 + , fieldName +#endif ) #if __GLASGOW_HASKELL__ < 902 @@ -170,6 +177,33 @@ import qualified GHC.Types.Basic #endif +#if __GLASGOW_HASKELL__ >= 902 +import GHC.Utils.Logger (getLogger) +#endif + +#if __GLASGOW_HASKELL__ == 902 +import GHC.Types.Error (mkWarnMsg, mkErr, mkDecorated) +import GHC.Driver.Errors (printOrThrowWarnings) +#endif + +#if __GLASGOW_HASKELL__ >= 904 +import GHC.Driver.Config.Diagnostic (initDiagOpts) +import GHC.Driver.Errors (printOrThrowDiagnostics) +import GHC.Driver.Errors.Types (GhcMessage(GhcUnknownMessage)) +import GHC.Types.Error (mkPlainError, mkMessages, mkPlainDiagnostic) +import GHC.Utils.Error (mkMsgEnvelope, mkErrorMsgEnvelope) +#endif + +#if __GLASGOW_HASKELL__ >= 908 +import GHC.Types.Error (mkSimpleUnknownDiagnostic) +#elif __GLASGOW_HASKELL__ >= 906 +import GHC.Types.Error (UnknownDiagnostic(..)) +#endif + +#if __GLASGOW_HASKELL__ >= 906 +import GHC.Driver.Config.Diagnostic (initPrintConfig) +#endif + {------------------------------------------------------------------------------- Name resolution -------------------------------------------------------------------------------} @@ -276,7 +310,11 @@ #endif mkFunBind :: Located RdrName -> [LMatch GhcPs (LHsExpr GhcPs)] -> HsBind GhcPs +#if __GLASGOW_HASKELL__ >= 908 +mkFunBind (reLocA -> n) = GHC.mkFunBind (Generated DoPmc) n +#else mkFunBind (reLocA -> n) = GHC.mkFunBind Generated n +#endif #if __GLASGOW_HASKELL__ < 900 type HsModule = GHC.HsModule GhcPs @@ -347,8 +385,6 @@ #if __GLASGOW_HASKELL__ >= 906 instance HasDefaultExt (LayoutInfo GhcPs) where defExt = NoLayoutInfo -instance HasDefaultExt GHC.Types.Basic.Origin where - defExt = Generated instance HasDefaultExt SourceText where defExt = NoSourceText #elif __GLASGOW_HASKELL__ >= 900 @@ -356,6 +392,14 @@ defExt = NoLayoutInfo #endif +#if __GLASGOW_HASKELL__ >= 908 +instance HasDefaultExt GHC.Types.Basic.Origin where + defExt = Generated DoPmc +#elif __GLASGOW_HASKELL__ >= 906 +instance HasDefaultExt GHC.Types.Basic.Origin where + defExt = Generated +#endif + instance (HasDefaultExt a, HasDefaultExt b) => HasDefaultExt (a, b) where defExt = (defExt, defExt) @@ -386,7 +430,10 @@ Generalized @forall@ in 9.0 -------------------------------------------------------------------------------} -#if __GLASGOW_HASKELL__ >= 900 +#if __GLASGOW_HASKELL__ >= 908 +type HsTyVarBndr pass = GHC.HsTyVarBndr (HsBndrVis GhcPs) pass +type LHsTyVarBndr pass = GHC.LHsTyVarBndr (HsBndrVis GhcPs) pass +#elif __GLASGOW_HASKELL__ >= 900 type HsTyVarBndr pass = GHC.HsTyVarBndr () pass type LHsTyVarBndr pass = GHC.LHsTyVarBndr () pass #endif @@ -406,8 +453,10 @@ -> HsTyVarBndr GhcPs #if __GLASGOW_HASKELL__ < 900 userTyVar = UserTyVar -#else +#elif __GLASGOW_HASKELL__ < 908 userTyVar ext x = UserTyVar ext () (reLocA x) +#else +userTyVar ext x = UserTyVar ext HsBndrRequired (reLocA x) #endif kindedTyVar :: @@ -417,8 +466,10 @@ -> HsTyVarBndr GhcPs #if __GLASGOW_HASKELL__ < 900 kindedTyVar = KindedTyVar -#else +#elif __GLASGOW_HASKELL__ < 908 kindedTyVar ext k = KindedTyVar ext () (reLocA k) +#else +kindedTyVar ext k = KindedTyVar ext HsBndrRequired (reLocA k) #endif -- | Like 'hsTyVarName', but don't throw away the location information @@ -437,9 +488,9 @@ setDefaultSpecificity = id #else setDefaultSpecificity :: LHsTyVarBndr GhcPs -> GHC.LHsTyVarBndr Specificity GhcPs -setDefaultSpecificity = mapXRec @GhcPs $ \v -> case v of - UserTyVar ext () name -> UserTyVar ext SpecifiedSpec name - KindedTyVar ext () name kind -> KindedTyVar ext SpecifiedSpec name kind +setDefaultSpecificity = mapXRec @GhcPs $ \case + UserTyVar ext _ name -> UserTyVar ext SpecifiedSpec name + KindedTyVar ext _ name kind -> KindedTyVar ext SpecifiedSpec name kind #if __GLASGOW_HASKELL__ < 900 XTyVarBndr ext -> XTyVarBndr ext #endif @@ -545,7 +596,9 @@ Records -------------------------------------------------------------------------------} -#if __GLASGOW_HASKELL__ >= 902 +#if __GLASGOW_HASKELL__ >= 908 +type RupdFlds = LHsRecUpdFields GhcPs +#elif __GLASGOW_HASKELL__ >= 902 type RupdFlds = Either [LHsRecUpdField GhcPs] [LHsRecUpdProj GhcPs] #else type RupdFlds = [LHsRecUpdField GhcPs] @@ -558,8 +611,15 @@ simpleRecordUpdates = \case +#if __GLASGOW_HASKELL__ >= 908 + RegularRecUpdFields _ flds -> + mapM (aux (isUnambigous . unLoc)) flds + OverloadedRecUpdFields _ flds -> + mapM (aux (isSingleLabel . unLoc)) flds +#else Left flds -> mapM (aux (isUnambigous . unLoc)) flds Right flds -> mapM (aux (isSingleLabel . unLoc)) flds +#endif where aux :: forall lhs rhs. (lhs -> Maybe LRdrName) @@ -639,3 +699,73 @@ isUnambigous _ = Nothing #endif + +{------------------------------------------------------------------------------- + Diagnostics +-------------------------------------------------------------------------------} + +issueError :: SrcSpan -> SDoc -> Hsc () +issueError l errMsg = do +#if __GLASGOW_HASKELL__ == 902 + throwOneError $ + mkErr l neverQualify (mkDecorated [errMsg]) +#elif __GLASGOW_HASKELL__ >= 908 + throwOneError $ + mkErrorMsgEnvelope + l + neverQualify + (GhcUnknownMessage $ mkSimpleUnknownDiagnostic $ mkPlainError [] errMsg) +#elif __GLASGOW_HASKELL__ >= 906 + throwOneError $ + mkErrorMsgEnvelope + l + neverQualify + (GhcUnknownMessage $ UnknownDiagnostic $ mkPlainError [] errMsg) +#elif __GLASGOW_HASKELL__ >= 904 + throwOneError $ + mkErrorMsgEnvelope + l + neverQualify + (GhcUnknownMessage $ mkPlainError [] errMsg) +#else + dynFlags <- getDynFlags + throwOneError $ + mkErrMsg dynFlags l neverQualify errMsg +#endif + +issueWarning :: SrcSpan -> SDoc -> Hsc () +issueWarning l errMsg = do + dynFlags <- getDynFlags +#if __GLASGOW_HASKELL__ == 902 + logger <- getLogger + liftIO $ printOrThrowWarnings logger dynFlags . bag $ + mkWarnMsg l neverQualify errMsg +#elif __GLASGOW_HASKELL__ >= 906 + logger <- getLogger + dflags <- getDynFlags + let print_config = initPrintConfig dflags + liftIO $ printOrThrowDiagnostics logger print_config (initDiagOpts dynFlags) . mkMessages . bag $ + mkMsgEnvelope + (initDiagOpts dynFlags) + l + neverQualify +#if __GLASGOW_HASKELL__ >= 908 + (GhcUnknownMessage $ mkSimpleUnknownDiagnostic $ mkPlainDiagnostic WarningWithoutFlag [] errMsg) +#else + (GhcUnknownMessage $ UnknownDiagnostic $ mkPlainDiagnostic WarningWithoutFlag [] errMsg) +#endif +#elif __GLASGOW_HASKELL__ >= 904 + logger <- getLogger + liftIO $ printOrThrowDiagnostics logger (initDiagOpts dynFlags) . mkMessages . bag $ + mkMsgEnvelope + (initDiagOpts dynFlags) + l + neverQualify + (GhcUnknownMessage $ mkPlainDiagnostic WarningWithoutFlag [] errMsg) +#else + liftIO $ printOrThrowWarnings dynFlags . bag $ + mkWarnMsg dynFlags l neverQualify errMsg +#endif + where + bag :: a -> Bag a + bag = listToBag . (:[]) diff --git a/src/Data/Record/Internal/GHC/TemplateHaskellStyle.hs b/src/Data/Record/Internal/GHC/TemplateHaskellStyle.hs --- a/src/Data/Record/Internal/GHC/TemplateHaskellStyle.hs +++ b/src/Data/Record/Internal/GHC/TemplateHaskellStyle.hs @@ -14,9 +14,9 @@ module Data.Record.Internal.GHC.TemplateHaskellStyle ( -- * Names nameBase - , mkExpVar - , mkTyVar - , mkTyCon + , mkNameExp + , mkNameTy + , mkNameTyCon , pattern ExpVar , pattern TyVar , pattern TyCon @@ -105,11 +105,12 @@ ) where import Data.List (foldl') - -import Data.Record.Internal.GHC.Shim hiding (mkTyVar) import Data.List.NonEmpty (NonEmpty(..)) + import qualified Data.List.NonEmpty as NE +import Data.Record.Internal.GHC.Shim + {------------------------------------------------------------------------------- Internal auxiliary: types of names -------------------------------------------------------------------------------} @@ -132,32 +133,32 @@ nameBase = occNameString . rdrNameOcc . unLoc -- | Equivalent of 'Language.Haskell.TH.Syntax.mkName', for expression vars -mkExpVar :: SrcSpan -> String -> LRdrName -mkExpVar l = L l . mkRdrUnqual . mkVarOcc +mkNameExp :: SrcSpan -> String -> LRdrName +mkNameExp l = L l . mkRdrUnqual . mkVarOcc -- | Equivalent of 'Language.Haskell.TH.Syntax.mkName', for type vars -mkTyVar :: SrcSpan -> String -> LRdrName -mkTyVar l = L l . mkRdrUnqual . mkTyVarOcc +mkNameTy :: SrcSpan -> String -> LRdrName +mkNameTy l = L l . mkRdrUnqual . mkTyVarOcc -- | Equivalent of 'Language.Haskell.TH.Syntax.mkName', for type constructors -mkTyCon :: SrcSpan -> String -> LRdrName -mkTyCon l = L l . mkRdrUnqual . mkTcOcc +mkNameTyCon :: SrcSpan -> String -> LRdrName +mkNameTyCon l = L l . mkRdrUnqual . mkTcOcc --- | Inverse to 'mkExpVar' +-- | Inverse to 'mkNameExp' -- -- NOTE: Defined in terms of 'nameBase', so discards qualifiers. viewExpVar :: LRdrName -> Maybe String viewExpVar n | isTermVar n = Just (nameBase n) viewExpVar _otherwise = Nothing --- | Inverse to 'mkTyVar' +-- | Inverse to 'mkNameTy' -- -- NOTE: Defined in terms of 'nameBase', so discards qualifiers. viewTyVar :: LRdrName -> Maybe String viewTyVar n | isTypeVar n = Just (nameBase n) viewTyVar _otherwise = Nothing --- | Inverse to 'mkTyCon' +-- | Inverse to 'mkNameTyCon' viewTyCon :: LRdrName -> Maybe String viewTyCon n | isTypeCon n = Just (nameBase n) viewTyCon _otherwise = Nothing @@ -241,15 +242,25 @@ recUpdE :: LHsExpr GhcPs -> [(LRdrName, LHsExpr GhcPs)] -> LHsExpr GhcPs recUpdE = \recExpr -> updRec recExpr . map (uncurry updFld) where +#if __GLASGOW_HASKELL__ >= 908 + updRec :: LHsExpr GhcPs -> [LHsRecUpdField GhcPs GhcPs] -> LHsExpr GhcPs +#else updRec :: LHsExpr GhcPs -> [LHsRecUpdField GhcPs] -> LHsExpr GhcPs +#endif updRec expr fields = inheritLoc expr $ RecordUpd defExt expr -#if __GLASGOW_HASKELL__ >= 902 +#if __GLASGOW_HASKELL__ >= 908 + $ RegularRecUpdFields noExtField +#elif __GLASGOW_HASKELL__ >= 902 $ Left #endif fields +#if __GLASGOW_HASKELL__ >= 908 + updFld :: LRdrName -> LHsExpr GhcPs -> LHsRecUpdField GhcPs GhcPs +#else updFld :: LRdrName -> LHsExpr GhcPs -> LHsRecUpdField GhcPs +#endif updFld name val = inheritLoc name $ #if __GLASGOW_HASKELL__ >= 904 HsFieldBind @@ -524,10 +535,10 @@ viewRecField (L _ ConDeclField { - cd_fld_names = [L _ fieldName] + cd_fld_names = [L _ name] , cd_fld_type = ty } - ) = Just $ (viewFieldOcc fieldName, ty) + ) = Just $ (viewFieldOcc name, ty) viewRecField _otherwise = Nothing viewFieldOcc :: FieldOcc GhcPs -> LRdrName diff --git a/src/Data/Record/Internal/Plugin/CodeGen.hs b/src/Data/Record/Internal/Plugin/CodeGen.hs --- a/src/Data/Record/Internal/Plugin/CodeGen.hs +++ b/src/Data/Record/Internal/Plugin/CodeGen.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -15,7 +16,7 @@ import qualified Data.Generics as SYB import Data.Record.Internal.GHC.Fresh -import Data.Record.Internal.GHC.Shim hiding (mkTyVar) +import Data.Record.Internal.GHC.Shim import Data.Record.Internal.GHC.TemplateHaskellStyle import Data.Record.Internal.Plugin.Names import Data.Record.Internal.Plugin.Record @@ -112,7 +113,7 @@ -- cannot clash with anything else (no other type vars can be in scope). vars :: [LRdrName] vars = [ - mkTyVar recordAnnLoc ("lr_f" <> show i) + mkNameTy recordAnnLoc ("lr_f" <> show i) | (i, _) <- zip [1 :: Int ..] recordFields ] @@ -184,7 +185,7 @@ toVector :: m [LHsDecl GhcPs] toVector = do - x <- freshName $ mkExpVar recordAnnLoc "x" + x <- freshName $ mkNameExp recordAnnLoc "x" args <- mapM (freshName . fieldName) recordFields return $ [ sigD name $ @@ -239,9 +240,9 @@ => QualifiedNames -> Record -> m [LHsDecl GhcPs] genIndexedAccessor QualifiedNames{..} r@Record{..} = do - x <- freshName' False $ mkTyVar recordAnnLoc "x" - n <- freshName $ mkExpVar recordAnnLoc "n" - t <- freshName $ mkExpVar recordAnnLoc "t" + x <- freshName' False $ mkNameTy recordAnnLoc "x" + n <- freshName $ mkNameExp recordAnnLoc "n" + t <- freshName $ mkNameExp recordAnnLoc "t" return [ sigD name $ funT @@ -279,10 +280,10 @@ => QualifiedNames -> Record -> m [LHsDecl GhcPs] genUnsafeSetIndex QualifiedNames{..} r@Record{..} = do - x <- freshName' False $ mkTyVar recordAnnLoc "x" - n <- freshName $ mkExpVar recordAnnLoc "n" - t <- freshName $ mkExpVar recordAnnLoc "t" - val <- freshName $ mkExpVar recordAnnLoc "val" + x <- freshName' False $ mkNameTy recordAnnLoc "x" + n <- freshName $ mkNameExp recordAnnLoc "n" + t <- freshName $ mkNameExp recordAnnLoc "t" + val <- freshName $ mkNameExp recordAnnLoc "val" return [ sigD name $ ConT type_Int @@ -316,8 +317,8 @@ => QualifiedNames -> Record -> Field -> m (LHsDecl GhcPs) genHasFieldInstance QualifiedNames{..} r@Record{..} Field{..} = do - x <- freshName' False $ mkTyVar recordAnnLoc "x" - t <- freshName $ mkExpVar recordAnnLoc "t" + x <- freshName' False $ mkNameTy recordAnnLoc "x" + t <- freshName $ mkNameExp recordAnnLoc "t" return $ instanceD [equalP (VarT x) fieldType] @@ -362,7 +363,7 @@ MonadFresh m => QualifiedNames -> Record -> m (LHsDecl GhcPs) genConstraintsClass QualifiedNames{..} r@Record{..} = do - c <- freshName' False $ mkTyVar recordAnnLoc "c" + c <- freshName' False $ mkNameTy recordAnnLoc "c" return $ classD [] (nameConstraints r) @@ -432,7 +433,7 @@ => QualifiedNames -> Record -> m (LHsExpr GhcPs) genDict names@QualifiedNames{..} Record{..} = do - p <- freshName $ mkExpVar recordAnnLoc "p" + p <- freshName $ mkNameExp recordAnnLoc "p" return $ lamE1 (varP p) $ appE @@ -458,7 +459,7 @@ => QualifiedNames -> Record -> m (LHsDecl GhcPs) genConstraintsInstance names r@Record{..} = do body <- genDict names r - c <- freshName' False $ mkTyVar recordAnnLoc "c" + c <- freshName' False $ mkNameTy recordAnnLoc "c" return $ instanceD (genRequiredConstraints r (VarT c)) @@ -489,7 +490,7 @@ => QualifiedNames -> Record -> DynFlags -> m (LHsExpr GhcPs) genMetadata names@QualifiedNames{..} r@Record{..} dynFlags = do - p <- freshName $ mkExpVar recordAnnLoc "p" + p <- freshName $ mkNameExp recordAnnLoc "p" return $ lamE1 (varP p) $ appsE (VarE mkMetadata) [ @@ -525,7 +526,7 @@ => QualifiedNames -> Record -> m (LHsExpr GhcPs) genFrom QualifiedNames{..} r@Record{..} = do - x <- freshName $ mkExpVar recordAnnLoc "x" + x <- freshName $ mkNameExp recordAnnLoc "x" return $ lamE1 (varP x) $ VarE anyArrayToRep `appE` (VarE (nameVectorFrom r) `appE` VarE x) @@ -545,7 +546,7 @@ => QualifiedNames -> Record -> m (LHsExpr GhcPs) genTo QualifiedNames{..} r@Record{..} = do - x <- freshName $ mkExpVar recordAnnLoc "x" + x <- freshName $ mkNameExp recordAnnLoc "x" return $ lamE1 (varP x) $ VarE (nameVectorTo r) `appE` (VarE anyArrayFromRep `appE` VarE x) @@ -689,12 +690,12 @@ nameConstraints :: Record -> LRdrName nameDictConstraints :: Record -> LRdrName -nameVectorFrom = mkDerived mkExpVar "vectorFrom" -nameVectorTo = mkDerived mkExpVar "vectorTo" -nameUnsafeGetIndex = mkDerived mkExpVar "unsafeGetIndex" -nameUnsafeSetIndex = mkDerived mkExpVar "unsafeSetIndex" -nameConstraints = mkDerived mkTyCon "Constraints_" -nameDictConstraints = mkDerived mkExpVar "dictConstraints_" +nameVectorFrom = mkDerived mkNameExp "vectorFrom" +nameVectorTo = mkDerived mkNameExp "vectorTo" +nameUnsafeGetIndex = mkDerived mkNameExp "unsafeGetIndex" +nameUnsafeSetIndex = mkDerived mkNameExp "unsafeSetIndex" +nameConstraints = mkDerived mkNameTyCon "Constraints_" +nameDictConstraints = mkDerived mkNameExp "dictConstraints_" {------------------------------------------------------------------------------- Auxiliary diff --git a/src/Data/Record/Plugin.hs b/src/Data/Record/Plugin.hs --- a/src/Data/Record/Plugin.hs +++ b/src/Data/Record/Plugin.hs @@ -89,28 +89,6 @@ import Data.Record.Internal.Plugin.Record import Data.Record.Internal.Plugin.Names -#if __GLASGOW_HASKELL__ >= 902 -import GHC.Utils.Logger (getLogger) -#endif - -#if __GLASGOW_HASKELL__ == 902 -import GHC.Types.Error (mkWarnMsg, mkErr, mkDecorated) -import GHC.Driver.Errors (printOrThrowWarnings) -#endif - -#if __GLASGOW_HASKELL__ >= 904 -import GHC.Driver.Config.Diagnostic (initDiagOpts) -import GHC.Driver.Errors (printOrThrowDiagnostics) -import GHC.Driver.Errors.Types (GhcMessage(GhcUnknownMessage)) -import GHC.Types.Error (mkPlainError, mkMessages, mkPlainDiagnostic) -import GHC.Utils.Error (mkMsgEnvelope, mkErrorMsgEnvelope) -#endif - -#if __GLASGOW_HASKELL__ >= 906 -import GHC.Types.Error (UnknownDiagnostic(..)) -import GHC.Driver.Config.Diagnostic (initPrintConfig) -#endif - {------------------------------------------------------------------------------- Top-level: the plugin proper -------------------------------------------------------------------------------} @@ -249,63 +227,3 @@ isEnabled :: DynFlags -> RequiredExtension -> Bool isEnabled dynflags (RequiredExtension exts) = any (`xopt` dynflags) exts - -{------------------------------------------------------------------------------- - Internal auxiliary --------------------------------------------------------------------------------} - -issueError :: SrcSpan -> SDoc -> Hsc () -issueError l errMsg = do -#if __GLASGOW_HASKELL__ == 902 - throwOneError $ - mkErr l neverQualify (mkDecorated [errMsg]) -#elif __GLASGOW_HASKELL__ >= 906 - throwOneError $ - mkErrorMsgEnvelope - l - neverQualify - (GhcUnknownMessage $ UnknownDiagnostic $ mkPlainError [] errMsg) -#elif __GLASGOW_HASKELL__ >= 904 - throwOneError $ - mkErrorMsgEnvelope - l - neverQualify - (GhcUnknownMessage $ mkPlainError [] errMsg) -#else - dynFlags <- getDynFlags - throwOneError $ - mkErrMsg dynFlags l neverQualify errMsg -#endif - -issueWarning :: SrcSpan -> SDoc -> Hsc () -issueWarning l errMsg = do - dynFlags <- getDynFlags -#if __GLASGOW_HASKELL__ == 902 - logger <- getLogger - liftIO $ printOrThrowWarnings logger dynFlags . bag $ - mkWarnMsg l neverQualify errMsg -#elif __GLASGOW_HASKELL__ >= 906 - logger <- getLogger - dflags <- getDynFlags - let print_config = initPrintConfig dflags - liftIO $ printOrThrowDiagnostics logger print_config (initDiagOpts dynFlags) . mkMessages . bag $ - mkMsgEnvelope - (initDiagOpts dynFlags) - l - neverQualify - (GhcUnknownMessage $ UnknownDiagnostic $ mkPlainDiagnostic WarningWithoutFlag [] errMsg) -#elif __GLASGOW_HASKELL__ >= 904 - logger <- getLogger - liftIO $ printOrThrowDiagnostics logger (initDiagOpts dynFlags) . mkMessages . bag $ - mkMsgEnvelope - (initDiagOpts dynFlags) - l - neverQualify - (GhcUnknownMessage $ mkPlainDiagnostic WarningWithoutFlag [] errMsg) -#else - liftIO $ printOrThrowWarnings dynFlags . bag $ - mkWarnMsg dynFlags l neverQualify errMsg -#endif - where - bag :: a -> Bag a - bag = listToBag . (:[])