GitLab

Oleg Grenrus pushed to branch wip/T26295 at Glasgow Haskell Compiler / GHC

Commits:

a6237d55

by Oleg Grenrus at 2025-08-11T12:23:01+03:00

Allow definining HasField instances for naughty fields

Resolves #26295

... as HasField solver doesn't solve for fields with "naughty"
selectors, we could as well allow defining HasField instances for these
fields.

4 changed files:

compiler/GHC/Tc/Validity.hs
+ testsuite/tests/overloadedrecflds/should_run/T26295.hs
+ testsuite/tests/overloadedrecflds/should_run/T26295.stdout
testsuite/tests/overloadedrecflds/should_run/all.T

Changes:

compiler/GHC/Tc/Validity.hs

@@ -31,6 +31,7 @@ import GHC.Tc.Instance.Family
  import GHC.Tc.Types.Origin
  import GHC.Tc.Types.Rank
  import GHC.Tc.Errors.Types
 +import GHC.Tc.Utils.Env (tcLookupId)
  import GHC.Tc.Utils.TcType
  import GHC.Tc.Utils.Monad
  import GHC.Tc.Zonk.TcType
@@ -60,6 +61,8 @@ import qualified GHC.LanguageExtensions as LangExt
  import GHC.Types.Error
  import GHC.Types.Basic   ( TypeOrKind(..), UnboxedTupleOrSum(..)
                           , unboxedTupleOrSumExtension )
 +import GHC.Types.Id (isNaughtyRecordSelector)
 +import GHC.Types.FieldLabel (flSelector)
  import GHC.Types.Name
  import GHC.Types.Var.Env
  import GHC.Types.Var.Set
@@ -1718,8 +1721,17 @@ checkHasFieldInst cls tys@[_k_ty, _r_rep, _a_rep, lbl_ty, r_ty, _a_ty] =
        | otherwise -> case isStrLitTy lbl_ty of
         Just lbl
           | let lbl_str = FieldLabelString lbl
 -         , isJust (lookupTyConFieldLabel lbl_str tc)
 -         -> add_err $ IllegalHasFieldInstanceTyConHasField tc lbl_str
 +         , Just fl <- lookupTyConFieldLabel lbl_str tc
 +         -> do
 +            -- GHC does not provide HasField instances for naughty record selectors
 +            -- (see Note [Naughty record selectors] in GHC.Tc.TyCl.Utils),
 +            -- so don't prevent the user from writing such instances.
 +            -- See GHC.Tc.Instance.Class.matchHasField.
 +            -- Test case: T26295.
 +            sel_id <- tcLookupId $ flSelector fl
 +            if isNaughtyRecordSelector sel_id
 +            then return ()
 +            else add_err $ IllegalHasFieldInstanceTyConHasField tc lbl_str
           | otherwise
           -> return ()
         Nothing

testsuite/tests/overloadedrecflds/should_run/T26295.hs

 +{-# LANGUAGE GHC2021 #-}
 +{-# LANGUAGE GADTs #-}
 +{-# LANGUAGE DataKinds #-}
 +{-# LANGUAGE OverloadedRecordDot #-}
 +{-# LANGUAGE UndecidableInstances #-}
 +import GHC.Records
++
 +-- large-records mangles record definitions to look like below to
 +-- prevent selector function generation (even implicit ones)
 +data R = forall a b. (a ~ Int, b ~ Char) => MkR
 +   { field_a :: a
 +   , field_b :: b
 +   }
++
 +-- fields in R are naughty, so we can define custom HasField instancs for them
 +instance a ~ Int => HasField "field_a" R a where
 +    getField (MkR a _) = a
++
 +ex :: Int
 +ex = r.field_a
 +  where
 +    r :: R
 +    r = MkR 42 'x'
++
 +main :: IO ()
 +main = print ex

testsuite/tests/overloadedrecflds/should_run/T26295.stdout

+42

testsuite/tests/overloadedrecflds/should_run/all.T

@@ -20,3 +20,4 @@ test('T12243', normal, compile_and_run, [''])
  test('T11228', normal, compile_and_run, [''])
  test('T11671_run', normal, compile_and_run, [''])
  test('T17551b', [req_th], compile_and_run, [''])
 +test('T26295', [], compile_and_run, [''])