diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,10 @@ # Revision history for large-anon +## 0.3.1 -- 2024-05-30 + +* Support ghc 9.6 (and drop ghc <= 8.8) + [together with Gabriele Sales] + ## 0.3 -- 2023-07-04 * Critical bugfix (#146): incremental record construction was fundamentally diff --git a/large-anon.cabal b/large-anon.cabal --- a/large-anon.cabal +++ b/large-anon.cabal @@ -1,6 +1,6 @@ cabal-version: 2.4 name: large-anon -version: 0.3.0 +version: 0.3.1 synopsis: Scalable anonymous records description: The @large-anon@ package provides support for anonymous records in Haskell, with a focus on compile-time (and @@ -12,7 +12,7 @@ category: Records extra-source-files: CHANGELOG.md test/Test/Sanity/RebindableSyntax/Tests.hs -tested-with: GHC ==8.8.4 || ==8.10.7 || ==9.0.2 || ==9.2.8 || ==9.4.5 +tested-with: GHC ==8.10.7 || ==9.2.8 || ==9.4.8 || ==9.6.4 library exposed-modules: @@ -70,15 +70,16 @@ Data.Record.Anon.Internal.Plugin.Source.Options build-depends: - base >= 4.13 && < 4.18 - , aeson >= 1.4.4 && < 2.2 - , containers >= 0.6.2 && < 0.7 - , deepseq >= 1.4.4 && < 1.5 - , ghc-tcplugin-api >= 0.10 && < 0.11 + , aeson >= 1.4.4 && < 2.3 + , base >= 4.14 && < 4.19 + , containers >= 0.6.2 && < 0.8 + , deepseq >= 1.4.4 && < 1.6 + , ghc >= 8.10 && < 9.7 + , ghc-tcplugin-api >= 0.11 && < 0.12 , hashable >= 1.3 && < 1.5 - , mtl >= 2.2.1 && < 2.3 + , mtl >= 2.2.1 && < 2.4 , optics-core >= 0.3 && < 0.5 - , primitive >= 0.7.1 && < 0.8 + , primitive >= 0.8 && < 0.10 , record-hasfield >= 1.0 && < 1.1 , sop-core >= 0.5 && < 0.6 , syb >= 0.7 && < 0.8 @@ -87,9 +88,6 @@ -- large-generics 0.2 starts using 'SmallArray' instead of 'Vector' , large-generics >= 0.2 && < 0.3 - - -- Whatever version is bundled with ghc - , ghc hs-source-dirs: src default-language: diff --git a/src/Data/Record/Anon/Advanced.hs b/src/Data/Record/Anon/Advanced.hs --- a/src/Data/Record/Anon/Advanced.hs +++ b/src/Data/Record/Anon/Advanced.hs @@ -205,7 +205,7 @@ -- absentField r = get #c r -- :} -- ... --- ...No instance for (RowHasField "c"... +-- ...No instance for...RowHasField "c"... -- ... -- -- Type mismatches will result in regular type errors: @@ -226,7 +226,7 @@ -- unknownField r = get #b r -- :} -- ... --- ...No instance for (RowHasField "b"... +-- ...No instance for...RowHasField "b"... -- ... -- -- (Note that @x@ here is a variable, not a string.) It is important that the @@ -280,7 +280,7 @@ -- example = project -- :} -- ... --- ...No instance for (SubRow... +-- ...No instance for...SubRow... -- ... -- -- Type inference will work through projections: field types are unified based @@ -347,7 +347,7 @@ -- example r = get #b r -- :} -- ... --- ...No instance for (RowHasField "b"... +-- ...No instance for...RowHasField "b"... -- ... merge :: Record f r -> Record f r' -> Record f (Merge r r') merge = A.merge diff --git a/src/Data/Record/Anon/Internal/Core/FieldName.hs b/src/Data/Record/Anon/Internal/Core/FieldName.hs --- a/src/Data/Record/Anon/Internal/Core/FieldName.hs +++ b/src/Data/Record/Anon/Internal/Core/FieldName.hs @@ -63,6 +63,6 @@ showString "fromString " . showsPrec 11 (fieldNameLabel n) instance Outputable FieldName where - ppr = ppr . fieldNameLabel + ppr = pprString . fieldNameLabel diff --git a/src/Data/Record/Anon/Internal/Plugin/Source/GhcShim.hs b/src/Data/Record/Anon/Internal/Plugin/Source/GhcShim.hs --- a/src/Data/Record/Anon/Internal/Plugin/Source/GhcShim.hs +++ b/src/Data/Record/Anon/Internal/Plugin/Source/GhcShim.hs @@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE DisambiguateRecordFields #-} -- | Thin shim around the GHC API -- @@ -102,7 +103,6 @@ import GHC.Types.Name (mkInternalName) import GHC.Types.Name.Occurrence import GHC.Types.Name.Reader (RdrName(Exact), rdrNameOcc, mkRdrQual, mkRdrUnqual) -import GHC.Types.SrcLoc (LayoutInfo(NoLayoutInfo)) import GHC.Types.Unique (Unique) import GHC.Types.Unique.Supply (takeUniqFromSupply) import GHC.Utils.Monad @@ -113,13 +113,16 @@ import GHC.Driver.Errors import GHC.Types.SourceText (SourceText(NoSourceText)) import GHC.Unit.Finder (findImportedModule, FindResult(Found)) -import GHC.Unit.Types (IsBootInterface(NotBoot)) #else import GHC.Driver.Finder (findImportedModule) import GHC.Driver.Types import GHC.Types.Basic (SourceText(NoSourceText)) #endif +#if __GLASGOW_HASKELL__ >= 902 && __GLASGOW_HASKELL__ < 906 +import GHC.Unit.Types (IsBootInterface(NotBoot)) +#endif + #if __GLASGOW_HASKELL__ < 904 import Data.IORef @@ -131,14 +134,22 @@ import GHC.Driver.Errors.Types (GhcMessage(..)) import GHC.Iface.Env (lookupNameCache) import GHC.Rename.Names (renamePkgQual) -import GHC.Types.Error (MsgEnvelope(..), mkMessages) import GHC.Types.Name.Cache (NameCache, takeUniqFromNameCache) import GHC.Types.PkgQual (RawPkgQual(NoRawPkgQual)) import GHC.Utils.Error (mkPlainError) +import qualified GHC.Types.Error as Err #endif #endif +#if __GLASGOW_HASKELL__ >= 900 && __GLASGOW_HASKELL__ < 906 +import GHC.Types.SrcLoc (LayoutInfo(NoLayoutInfo)) +#endif + +#if __GLASGOW_HASKELL__ >= 906 +import GHC.Driver.Config.Diagnostic (initPrintConfig) +#endif + {------------------------------------------------------------------------------- Names -------------------------------------------------------------------------------} @@ -206,8 +217,18 @@ -- | Optionally @qualified@ import declaration importDecl :: Bool -> ModuleName -> LImportDecl GhcPs importDecl qualified name = reLocA $ noLoc $ ImportDecl { +#if __GLASGOW_HASKELL__ < 906 ideclExt = defExt +#else + ideclExt = XImportDeclPass { + ideclAnn = defExt + , ideclSourceText = NoSourceText + , ideclImplicit = False + } +#endif +#if __GLASGOW_HASKELL__ < 906 , ideclSourceSrc = NoSourceText +#endif , ideclName = reLocA $ noLoc name #if __GLASGOW_HASKELL__ >= 904 , ideclPkgQual = NoRawPkgQual @@ -215,19 +236,22 @@ , ideclPkgQual = Nothing #endif , ideclSafe = False +#if __GLASGOW_HASKELL__ < 906 , ideclImplicit = False +#endif , ideclAs = Nothing +#if __GLASGOW_HASKELL__ < 906 , ideclHiding = Nothing -#if __GLASGOW_HASKELL__ < 810 - , ideclQualified = qualified -#else - , ideclQualified = if qualified then QualifiedPre else NotQualified #endif + , ideclQualified = if qualified then QualifiedPre else NotQualified #if __GLASGOW_HASKELL__ < 900 , ideclSource = False #else , ideclSource = NotBoot #endif +#if __GLASGOW_HASKELL__ >= 906 + , ideclImportList = Nothing +#endif } issueWarning :: SrcSpan -> SDoc -> Hsc () @@ -239,11 +263,31 @@ mkWarnMsg l neverQualify errMsg #elif __GLASGOW_HASKELL__ >= 904 logger <- getLogger - liftIO $ printOrThrowDiagnostics logger (initDiagOpts dynFlags) . mkMessages . bag $ - MsgEnvelope { + +#if __GLASGOW_HASKELL__ < 906 + let printOrThrow :: Err.Messages GhcMessage -> IO () + printOrThrow = printOrThrowDiagnostics + logger + (initDiagOpts dynFlags) + + let msg :: Err.DiagnosticMessage + msg = mkPlainError [] errMsg +#else + let printOrThrow :: Err.Messages GhcMessage -> IO () + printOrThrow = printOrThrowDiagnostics + logger + (initPrintConfig dynFlags) + (initDiagOpts dynFlags) + + let msg :: Err.UnknownDiagnostic + msg = Err.UnknownDiagnostic $ + mkPlainError [] errMsg +#endif + liftIO $ printOrThrow . Err.mkMessages . bag $ + Err.MsgEnvelope { errMsgSpan = l , errMsgContext = neverQualify - , errMsgDiagnostic = GhcUnknownMessage $ mkPlainError [] errMsg + , errMsgDiagnostic = GhcUnknownMessage msg , errMsgSeverity = SevWarning } #else @@ -269,15 +313,10 @@ class HasDefaultExt a where defExt :: a -#if __GLASGOW_HASKELL__ < 810 -instance HasDefaultExt NoExt where - defExt = noExt -#else instance HasDefaultExt NoExtField where defExt = noExtField -#endif -#if __GLASGOW_HASKELL__ >= 900 +#if __GLASGOW_HASKELL__ >= 900 && __GLASGOW_HASKELL__ < 906 instance HasDefaultExt LayoutInfo where defExt = NoLayoutInfo #endif @@ -307,6 +346,9 @@ mkLabel l n = reLocA $ L l $ HsOverLabel defExt #if __GLASGOW_HASKELL__ < 902 - Nothing + Nothing -- RebindableSyntax +#elif __GLASGOW_HASKELL__ >= 906 + NoSourceText #endif + n diff --git a/src/Data/Record/Anon/Internal/Plugin/TC/Constraints/AllFields.hs b/src/Data/Record/Anon/Internal/Plugin/TC/Constraints/AllFields.hs --- a/src/Data/Record/Anon/Internal/Plugin/TC/Constraints/AllFields.hs +++ b/src/Data/Record/Anon/Internal/Plugin/TC/Constraints/AllFields.hs @@ -117,21 +117,10 @@ dictForField :: KnownField (Type, EvVar) -> TcPluginM 'Solve EvExpr dictForField KnownField{ knownFieldInfo = (fieldType, dict) } = do - return $ mkCoreConApps dataConDictAny $ concat [ - map Type typeArgsDict - , [ -- We have a dictionary of type @c a@ from the evidence we get - -- from ghc; we cast it to @c Any@ to serve as arg to @DictAny@. - mkCoreApps (Var idUnsafeCoerce) [ - Type $ mkAppTy allFieldsTypeConstraint fieldType - , Type $ mkAppTy allFieldsTypeConstraint anyAtKind - , Var dict - ] - ] + return $ mkCoreApps (Var idMkDictAny) $ concat [ + map Type (typeArgsDict ++ [fieldType]) + , [Var dict] ] - - -- Any at kind @k@ - anyAtKind :: Type - anyAtKind = mkTyConApp anyTyCon [allFieldsTypeKind] {------------------------------------------------------------------------------- Solver diff --git a/src/Data/Record/Anon/Internal/Plugin/TC/GhcTcPluginAPI.hs b/src/Data/Record/Anon/Internal/Plugin/TC/GhcTcPluginAPI.hs --- a/src/Data/Record/Anon/Internal/Plugin/TC/GhcTcPluginAPI.hs +++ b/src/Data/Record/Anon/Internal/Plugin/TC/GhcTcPluginAPI.hs @@ -21,6 +21,7 @@ -- * New functonality , isCanonicalVarEq , getModule + , pprString ) where import GHC.Stack @@ -36,10 +37,6 @@ import GHC.Core.Make import GHC.Utils.Outputable -#if __GLASGOW_HASKELL__ >= 808 && __GLASGOW_HASKELL__ < 810 -import TcRnTypes (Ct(..)) -#endif - #if __GLASGOW_HASKELL__ >= 810 && __GLASGOW_HASKELL__ < 900 import Constraint (Ct(..)) #endif @@ -53,7 +50,7 @@ #endif isCanonicalVarEq :: Ct -> Maybe (TcTyVar, Type) -#if __GLASGOW_HASKELL__ >= 808 && __GLASGOW_HASKELL__ < 902 +#if __GLASGOW_HASKELL__ >= 810 && __GLASGOW_HASKELL__ < 902 isCanonicalVarEq = \case CTyEqCan{..} -> Just (cc_tyvar, cc_rhs) CFunEqCan{..} -> Just (cc_fsk, mkTyConApp cc_fun cc_tyargs) @@ -98,3 +95,7 @@ , " in package " , pkg ] + +pprString :: String -> SDoc +pprString = text + diff --git a/src/Data/Record/Anon/Internal/Plugin/TC/NameResolution.hs b/src/Data/Record/Anon/Internal/Plugin/TC/NameResolution.hs --- a/src/Data/Record/Anon/Internal/Plugin/TC/NameResolution.hs +++ b/src/Data/Record/Anon/Internal/Plugin/TC/NameResolution.hs @@ -23,7 +23,7 @@ , idEvidenceKnownHash :: Id , idEvidenceRowHasField :: Id , idEvidenceSubRow :: Id - , idUnsafeCoerce :: Id + , idMkDictAny :: Id , tyConDictAny :: TyCon , tyConMerge :: TyCon , tyConFieldTypes :: TyCon @@ -60,7 +60,7 @@ idEvidenceKnownHash <- getVar "evidenceKnownHash" idEvidenceRowHasField <- getVar "evidenceRowHasField" idEvidenceSubRow <- getVar "evidenceSubRow" - idUnsafeCoerce <- getVar "noInlineUnsafeCo" + idMkDictAny <- getVar "mkDictAny" tyConDictAny <- getTyCon "DictAny" tyConFieldTypes <- getTyCon "FieldTypes" diff --git a/src/Data/Record/Anon/Internal/Util/StrictArray.hs b/src/Data/Record/Anon/Internal/Util/StrictArray.hs --- a/src/Data/Record/Anon/Internal/Util/StrictArray.hs +++ b/src/Data/Record/Anon/Internal/Util/StrictArray.hs @@ -254,11 +254,11 @@ i' = arrayIndex (sizeofSmallArray arr) i writeSmallArray :: ArrayIndex i => SmallMutableArray s a -> i -> a -> ST s () -writeSmallArray arr i a = boundsCheckM arr i' $ - SmallArray.writeSmallArray arr i' a - where - i' :: Int - i' = arrayIndex (sizeofSmallMutableArray arr) i +writeSmallArray arr i a = do + sz <- getSizeofSmallMutableArray arr + let i' = arrayIndex sz i + boundsCheckM arr i' $ + SmallArray.writeSmallArray arr i' a #ifdef DEBUG boundsCheck :: HasCallStack => SmallArray a -> Int -> r -> r @@ -288,3 +288,11 @@ boundsCheckM _arr _i k = k #endif +{------------------------------------------------------------------------------- + Auxiliary: support primitive < 0.9 +-------------------------------------------------------------------------------} + +#if !MIN_VERSION_primitive(0,9,0) +getSizeofSmallMutableArray :: SmallMutableArray s a -> ST s Int +getSizeofSmallMutableArray = return . sizeofSmallMutableArray +#endif diff --git a/src/Data/Record/Anon/Plugin/Internal/Runtime.hs b/src/Data/Record/Anon/Plugin/Internal/Runtime.hs --- a/src/Data/Record/Anon/Plugin/Internal/Runtime.hs +++ b/src/Data/Record/Anon/Plugin/Internal/Runtime.hs @@ -10,11 +10,14 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} +-- Since this module is intended for codegen, where we generate explicit type +-- arguments anyway, ambiguous types are a non-issue. +{-# LANGUAGE AllowAmbiguousTypes #-} + +-- Users should not need to import from this module directly. {-# OPTIONS_HADDOCK hide #-} -- | Runtime for code generated by the plugin --- --- Users should not need to import from this module directly. module Data.Record.Anon.Plugin.Internal.Runtime ( -- * Row Pair(..) @@ -34,6 +37,7 @@ -- * AllFields , AllFields(..) , DictAny(..) + , mkDictAny , DictAllFields , evidenceAllFields -- * KnownHash @@ -184,6 +188,17 @@ data DictAny c where DictAny :: c Any => DictAny c +mkDictAny :: forall k (c :: k -> Constraint) (a :: k). c a => DictAny c +mkDictAny = aux $ noInlineUnsafeCo @(Dict c a) @(Dict c Any) Dict + where + aux :: Dict c Any -> DictAny c + aux Dict = DictAny + +-- | Construct evidence for the 'AllFields' class +-- +-- For reasons currently unclear, /must/ be marked NOINLINE, otherwise we get +-- @-dcore-lint@ errors in @ghc 9.6@. +{-# NOINLINE evidenceAllFields #-} evidenceAllFields :: forall k r c. [DictAny c] -> DictAllFields k r c evidenceAllFields = Tagged . smallArrayFromList