[Git][ghc/ghc][master] Add test for #22424

[Marge Bot (@marge-bot)]

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC


Commits:
73b5c7ce by sheaf at 2023-07-23T10:28:18-04:00
Add test for #22424

This is a simple Template Haskell test in which we refer to
record selectors by their exact Names, in two different ways.

Fixes #22424

- - - - -


2 changed files:

- + testsuite/tests/overloadedrecflds/should_compile/T22424.hs
- testsuite/tests/overloadedrecflds/should_compile/all.T


Changes:

=====================================
testsuite/tests/overloadedrecflds/should_compile/T22424.hs
=====================================
@@ -0,0 +1,40 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE NoFieldSelectors #-}
+
+module T22424 where
+
+import Language.Haskell.TH
+import Language.Haskell.TH.Syntax
+
+{-
+data R1 = C1 { fld :: Bool }
+data R2 = C2 { fld :: Bool }
+fun x1 x2 = fld x1 && fld x2 -- referring to the two different 'fld's
+-}
+
+$(do
+    let noBang = Bang NoSourceUnpackedness NoSourceStrictness
+    let mkData tn cn fn = (DataD [] tn [] Nothing [RecC cn [(fn, noBang, ConT ''Bool)]] [], fn)
+    (r1, fld1) <- mkData <$> newName "R1" <*> newName "C1" <*> newName "fld"
+    (r2, fld2) <- mkData <$> newName "R2" <*> newName "C2" <*> newName "fld"
+    fun <- newName "fun"
+    x1 <- newName "x1"
+    x2 <- newName "x2"
+    let expr = UInfixE (VarE fld1 `AppE` VarE x1) (VarE '(&&)) (VarE fld2 `AppE` VarE x2)
+        fun_decl = FunD fun [Clause [VarP x1, VarP x2] (NormalB expr) []]
+    pure [r1,r2,fun_decl]
+ )
+
+$(do
+    let noBang = Bang NoSourceUnpackedness NoSourceStrictness
+    let mkData tn cn fn = (DataD [] tn [] Nothing [RecC cn [(fn, noBang, ConT ''Bool)]] [], fn)
+    (r1, fld1) <- mkData <$> newName "R1'" <*> newName "C1'" <*> pure (mkNameG_fld "me" "T22424" "C1'" "fld'")
+    (r2, fld2) <- mkData <$> newName "R2'" <*> newName "C2'" <*> pure (mkNameG_fld "me" "T22424" "C2'" "fld'")
+    fun <- newName "fun'"
+    x1 <- newName "x1"
+    x2 <- newName "x2"
+    let expr = UInfixE (VarE fld1 `AppE` VarE x1) (VarE '(&&)) (VarE fld2 `AppE` VarE x2)
+        fun_decl = FunD fun [Clause [VarP x1, VarP x2] (NormalB expr) []]
+    pure [r1,r2,fun_decl]
+ )


=====================================
testsuite/tests/overloadedrecflds/should_compile/all.T
=====================================
@@ -54,5 +54,6 @@ test('T22106_A', [extra_files(['T22106_aux.hs'])], multimod_compile, ['T22106_A'
 test('T22106_B', [extra_files(['T22106_aux.hs'])], multimod_compile, ['T22106_B', '-v0'])
 test('T22106_C', [extra_files(['T22106_aux.hs'])], multimod_compile_fail, ['T22106_C', '-v0'])
 test('T22106_D', [extra_files(['T22106_aux.hs'])], multimod_compile, ['T22106_D', '-v0'])
+test('T22424', req_th, compile, ['-this-unit-id="me"'])
 test('T23279', [extra_files(['T23279_aux.hs'])], multimod_compile, ['T23279', '-v0'])
 test('T23557', [extra_files(['T23557_aux.hs'])], multimod_compile, ['T23557', '-v0'])



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/73b5c7ce33929e1f7c9283ed7c2860aa40f6d0ec

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/73b5c7ce33929e1f7c9283ed7c2860aa40f6d0ec
You're receiving this email because of your account on gitlab.haskell.org.


-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20230723/d8f780aa/attachment-0001.html>