diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,9 @@ # Revision history for large-anon +## 0.1.1 -- 2022-07-22 + +* Support for ghc 9.2 (#116) + ## 0.1.0.0 -- 2022-04-06 -* First public release +* First public release 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.1.0.0 +version: 0.1.1 synopsis: Scalable anonymous records description: The @large-anon@ package provides support for anonymous records in Haskell, with a focus on compile-time (and @@ -11,7 +11,7 @@ maintainer: edsko@well-typed.com category: Records extra-source-files: CHANGELOG.md -tested-with: GHC ==8.8.4 || ==8.10.7 || ==9.0.2 +tested-with: GHC ==8.8.4 || ==8.10.7 || ==9.0.2 || ==9.2.2 library exposed-modules: @@ -69,10 +69,10 @@ build-depends: base >= 4.13 && < 4.18 - , aeson >= 1.4.4 && < 2.1 + , aeson >= 1.4.4 && < 2.2 , containers >= 0.6.2 && < 0.7 - , ghc-tcplugin-api >= 0.7.1 && < 0.8 - , hashable >= 1.3 && < 1.4 + , ghc-tcplugin-api >= 0.8 && < 0.9 + , hashable >= 1.3 && < 1.5 , mtl >= 2.2.1 && < 2.3 , optics-core >= 0.3 && < 0.5 , primitive >= 0.7.1 && < 0.8 @@ -173,11 +173,13 @@ -Wno-unticked-promoted-constructors -fno-show-valid-hole-fits - if impl(ghc >= 8.10) - ghc-options: -Wunused-packages + -- Not sure why, but ghc warns about record-hasfield being unused, + -- despite it actually being required. So for now we just disable this check. + -- if impl(ghc >= 8.10) + -- ghc-options: -Wunused-packages if impl(ghc >= 9.0.1) - -- Work out ghc problem. See more detailed discussion in large-records. + -- Work around ghc problem. See more detailed discussion in large-records. ghc-options: -Wno-unused-imports Flag debug diff --git a/src/Data/Record/Anon/Internal/Plugin/Source.hs b/src/Data/Record/Anon/Internal/Plugin/Source.hs --- a/src/Data/Record/Anon/Internal/Plugin/Source.hs +++ b/src/Data/Record/Anon/Internal/Plugin/Source.hs @@ -1,6 +1,7 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TupleSections #-} +{-# LANGUAGE ViewPatterns #-} module Data.Record.Anon.Internal.Plugin.Source (sourcePlugin) where @@ -37,7 +38,7 @@ } transformExpr :: Options -> LHsExpr GhcPs -> NamingT Hsc (LHsExpr GhcPs) -transformExpr options@Options{debug} e@(L l expr) +transformExpr options@Options{debug} e@(reLoc -> L l expr) | RecordCon _ext (L _ nm) (HsRecFields flds dotdot) <- expr , Unqual nm' <- nm , Nothing <- dotdot @@ -53,7 +54,10 @@ getField :: LHsRecField GhcPs (LHsExpr GhcPs) -> Maybe (FastString, LHsExpr GhcPs) - getField (L _ (HsRecField (L _ fieldOcc) arg pun)) + getField (L _ (HsRecField + { hsRecFieldLbl = L _ fieldOcc + , hsRecFieldArg = arg + , hsRecPun = pun })) | FieldOcc _ (L _ nm) <- fieldOcc , Unqual nm' <- nm , not pun @@ -160,10 +164,7 @@ -------------------------------------------------------------------------------} mkVar :: SrcSpan -> RdrName -> LHsExpr GhcPs -mkVar l name = L l $ HsVar defExt (L l name) - -mkLabel :: SrcSpan -> FastString -> LHsExpr GhcPs -mkLabel l n = L l $ HsOverLabel defExt Nothing n +mkVar l name = reLocA $ L l $ HsVar defExt (reLocA $ L l name) -- | Construct simple lambda -- 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 @@ -11,9 +11,15 @@ -- * Extensions HasDefaultExt(..) +#if __GLASGOW_HASKELL__ < 902 + -- * Exact-print annotations + , reLoc, reLocA +#endif + -- * Miscellaneous , importDecl , issueWarning + , mkLabel #if __GLASGOW_HASKELL__ < 900 , mkHsApps #endif @@ -35,14 +41,21 @@ , module GHC , module GHC.Data.FastString , module GHC.Driver.Main - , module GHC.Driver.Types , module GHC.Types.Name , module GHC.Types.Name.Cache , module GHC.Types.Name.Occurrence , module GHC.Types.Name.Reader , module GHC.Types.Unique.Supply , module GHC.Utils.Outputable + +#if __GLASGOW_HASKELL__ < 902 + , module GHC.Driver.Types +#else + , module GHC.Driver.Errors + , module GHC.Driver.Env.Types + , module GHC.Types.SourceText #endif +#endif ) where #if __GLASGOW_HASKELL__ < 900 @@ -70,7 +83,14 @@ import GHC.Data.Bag (listToBag) import GHC.Data.FastString (FastString) import GHC.Driver.Main (getHscEnv) + +#if __GLASGOW_HASKELL__ >= 902 +import GHC.Driver.Errors +import GHC.Driver.Env.Types +import GHC.Types.SourceText +#else import GHC.Driver.Types +#endif import GHC.Plugins import GHC.Types.Name (mkInternalName) import GHC.Types.Name.Cache (NameCache(nsUniqs)) @@ -88,10 +108,10 @@ -- | Optionally @qualified@ import declaration importDecl :: Bool -> ModuleName -> LImportDecl GhcPs -importDecl qualified name = noLoc $ ImportDecl { +importDecl qualified name = reLocA $ noLoc $ ImportDecl { ideclExt = defExt , ideclSourceSrc = NoSourceText - , ideclName = noLoc name + , ideclName = reLocA $ noLoc name , ideclPkgQual = Nothing , ideclSafe = False , ideclImplicit = False @@ -112,8 +132,14 @@ issueWarning :: SrcSpan -> SDoc -> Hsc () issueWarning l errMsg = do dynFlags <- getDynFlags +#if __GLASGOW_HASKELL__ >= 902 + logger <- getLogger + liftIO $ printOrThrowWarnings logger dynFlags . listToBag . (:[]) $ + mkWarnMsg l neverQualify errMsg +#else liftIO $ printOrThrowWarnings dynFlags . listToBag . (:[]) $ mkWarnMsg dynFlags l neverQualify errMsg +#endif #if __GLASGOW_HASKELL__ < 900 mkHsApps :: @@ -143,3 +169,32 @@ defExt = NoLayoutInfo #endif +#if __GLASGOW_HASKELL__ >= 902 +instance HasDefaultExt (EpAnn ann) where + defExt = noAnn +#endif + +{------------------------------------------------------------------------------- + Exact-print annotations +-------------------------------------------------------------------------------} + +#if __GLASGOW_HASKELL__ < 902 +reLoc :: Located a -> Located a +reLoc = id + +reLocA :: Located a -> Located a +reLocA = id +#endif + + +{------------------------------------------------------------------------------- + mkLabel +-------------------------------------------------------------------------------} + +mkLabel :: SrcSpan -> FastString -> LHsExpr GhcPs +mkLabel l n = reLocA $ L l + $ HsOverLabel defExt +#if __GLASGOW_HASKELL__ < 902 + Nothing +#endif + n diff --git a/src/Data/Record/Anon/Internal/Plugin/TC/Constraints/RowHasField.hs b/src/Data/Record/Anon/Internal/Plugin/TC/Constraints/RowHasField.hs --- a/src/Data/Record/Anon/Internal/Plugin/TC/Constraints/RowHasField.hs +++ b/src/Data/Record/Anon/Internal/Plugin/TC/Constraints/RowHasField.hs @@ -76,18 +76,21 @@ -> Ct -> ParseResult Void (GenLocated CtLoc CRowHasField) parseRowHasField tcs rn@ResolvedNames{..} = - parseConstraint' clsRowHasField $ \[k, n, r, a] -> do - label <- ParsedRow.parseFieldLabel n - fields <- ParsedRow.parseFields tcs rn r - - return $ CRowHasField { - hasFieldLabel = label - , hasFieldRecord = fields - , hasFieldTypeKind = k - , hasFieldTypeLabel = n - , hasFieldTypeRow = r - , hasFieldTypeField = a - } + parseConstraint' clsRowHasField $ \ args -> + case args of + [k, n, r, a] -> do + label <- ParsedRow.parseFieldLabel n + fields <- ParsedRow.parseFields tcs rn r + return $ CRowHasField { + hasFieldLabel = label + , hasFieldRecord = fields + , hasFieldTypeKind = k + , hasFieldTypeLabel = n + , hasFieldTypeRow = r + , hasFieldTypeField = a + } + _ -> pprPanic "parseRowHasField: expected 4 arguments" $ + ( text "args:" <+> ppr args ) {------------------------------------------------------------------------------- Evidence diff --git a/src/Data/Record/Anon/Internal/Plugin/TC/Constraints/SubRow.hs b/src/Data/Record/Anon/Internal/Plugin/TC/Constraints/SubRow.hs --- a/src/Data/Record/Anon/Internal/Plugin/TC/Constraints/SubRow.hs +++ b/src/Data/Record/Anon/Internal/Plugin/TC/Constraints/SubRow.hs @@ -67,16 +67,20 @@ -> Ct -> ParseResult Void (GenLocated CtLoc CSubRow) parseSubRow tcs rn@ResolvedNames{..} = - parseConstraint' clsSubRow $ \[typeKind, typeLHS, typeRHS] -> do - fieldsLHS <- ParsedRow.parseFields tcs rn typeLHS - fieldsRHS <- ParsedRow.parseFields tcs rn typeRHS - return $ CSubRow { - subrowParsedLHS = fieldsLHS - , subrowParsedRHS = fieldsRHS - , subrowTypeLHS = typeLHS - , subrowTypeRHS = typeRHS - , subrowTypeKind = typeKind - } + parseConstraint' clsSubRow $ \ args -> + case args of + [typeKind, typeLHS, typeRHS] -> do + fieldsLHS <- ParsedRow.parseFields tcs rn typeLHS + fieldsRHS <- ParsedRow.parseFields tcs rn typeRHS + return $ CSubRow { + subrowParsedLHS = fieldsLHS + , subrowParsedRHS = fieldsRHS + , subrowTypeLHS = typeLHS + , subrowTypeRHS = typeRHS + , subrowTypeKind = typeKind + } + _ -> pprPanic "parseSubRow: expected 3 arguments" $ + text "args" <+> ppr args {------------------------------------------------------------------------------- Evidence 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 @@ -18,10 +18,6 @@ , module GHC.Core.Make , module GHC.Utils.Outputable - -- * Additional exports - , splitAppTys - , unpackFS - -- * New functonality , isCanonicalVarEq ) where @@ -38,26 +34,18 @@ import GHC.Utils.Outputable #if __GLASGOW_HASKELL__ >= 808 && __GLASGOW_HASKELL__ < 810 -import FastString (unpackFS) import TcRnTypes (Ct(..)) -import Type (splitAppTys) #endif #if __GLASGOW_HASKELL__ >= 810 && __GLASGOW_HASKELL__ < 900 import Constraint (Ct(..)) -import FastString (unpackFS) -import Type (splitAppTys) #endif #if __GLASGOW_HASKELL__ >= 900 && __GLASGOW_HASKELL__ < 902 -import GHC.Core.Type (splitAppTys) -import GHC.Data.FastString (unpackFS) import GHC.Tc.Types.Constraint (Ct(..)) #endif #if __GLASGOW_HASKELL__ >= 902 -import GHC.Core.Type (splitAppTys) -import GHC.Data.FastString (unpackFS) import GHC.Tc.Types.Constraint (Ct(..), CanEqLHS(..)) #endif 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 @@ -76,7 +76,7 @@ getModule :: MonadTcPlugin m => String -> String -> m Module getModule pkg modl = do - r <- findImportedModule (mkModuleName modl) (Just (fsLit pkg)) + r <- findImportedModule (mkModuleName modl) (OtherPkg $ stringToUnitId pkg) case r of Found _ m -> return m _otherwise -> panic $ "Could not find " ++ modl ++ " in package " ++ pkg diff --git a/src/Data/Record/Anon/Internal/Util/SmallHashMap.hs b/src/Data/Record/Anon/Internal/Util/SmallHashMap.hs --- a/src/Data/Record/Anon/Internal/Util/SmallHashMap.hs +++ b/src/Data/Record/Anon/Internal/Util/SmallHashMap.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} @@ -47,7 +48,11 @@ newtype Hashed k = Hashed k deriving (Show) +#if MIN_VERSION_hashable(1,4,0) +instance Hashable k => Eq (Hashed k) where +#else instance (Hashable k, Eq k) => Eq (Hashed k) where +#endif Hashed a == Hashed b = and [ hash a == hash b , a == b diff --git a/test/Test/Infra/DynRecord/Advanced.hs b/test/Test/Infra/DynRecord/Advanced.hs --- a/test/Test/Infra/DynRecord/Advanced.hs +++ b/test/Test/Infra/DynRecord/Advanced.hs @@ -138,7 +138,7 @@ setter :: Record f r -> Record f r' (getter, setter) = Anon.lens r -toRecord :: forall k (r :: Row k) (f :: k -> *) proxy. +toRecord :: forall k (r :: Row k) (f :: k -> Type) proxy. ( IsValue f , KnownFields r , SubRow r r