Add regression test for #22611.wip/andreask/alterf-test

A case were a function used to fail to specialize, but now does.

3 files changed, 310 insertions, 0 deletions

diff --git a/testsuite/tests/simplCore/should_compile/T22611.hs b/testsuite/tests/simplCore/should_compile/T22611.hs
new file mode 100644
index 0000000000..9e5af2fbdb
--- /dev/null
+++ b/testsuite/tests/simplCore/should_compile/T22611.hs
@@ -0,0 +1,23 @@
+-- The method `alterF` inside containers is marked as INLINEABLE
+-- and hence should be specialized to the `CheckRes` Functor.
+
+-- This only started to work with 9.6, this test checks that we don't
+-- regress on this.
+
+{-# language LambdaCase, Strict, DeriveFunctor, DerivingStrategies #-}
+
+module T22611 where
+
+import Data.Map.Strict as Map
+import qualified Data.Map.Strict as Map
+
+foo :: Either Int Char -> Map (Either Int Char) v -> Maybe (v, (Map (Either Int Char) v))
+foo x subst = case Map.alterF alt x subst of
+  NotFound -> foo (fmap (toEnum . (+1) . fromEnum) x) subst
+  Found p q -> Just (p, q)
+  where
+    alt :: Maybe a1 -> CheckRes a1 (Maybe a2)
+    alt = (\case {Nothing -> NotFound; Just t -> Found t Nothing})
+
+data CheckRes a m = NotFound | Found !a ~m
+  deriving stock Functor
diff --git a/testsuite/tests/simplCore/should_compile/T22611.stderr b/testsuite/tests/simplCore/should_compile/T22611.stderr
new file mode 100644
index 0000000000..709751732d
--- /dev/null
+++ b/testsuite/tests/simplCore/should_compile/T22611.stderr
@@ -0,0 +1,285 @@
+
+==================== Tidy Core ====================
+Result size of Tidy Core
+  = {terms: 544, types: 486, coercions: 0, joins: 0/7}
+
+$WFound
+  = \ @a @m conrep conrep1 ->
+      case conrep of conrep2 { __DEFAULT -> Found conrep2 conrep1 }
+
+$fFunctorCheckRes_$c<$
+  = \ @a @a1 @b z ds ->
+      case z of z1 { __DEFAULT ->
+      case ds of {
+        NotFound -> NotFound;
+        Found a2 a3 -> Found a2 z1
+      }
+      }
+
+$fFunctorCheckRes_$cfmap
+  = \ @a @a1 @b f ds ->
+      case f of f1 { __DEFAULT ->
+      case ds of {
+        NotFound -> NotFound;
+        Found a2 a3 -> Found a2 (f1 a3)
+      }
+      }
+
+$fFunctorCheckRes
+  = \ @a -> C:Functor $fFunctorCheckRes_$cfmap $fFunctorCheckRes_$c<$
+
+Rec {
+$w$sgo15
+  = \ @a1 ww ww1 ds ds1 ->
+      case ds of ds2 { __DEFAULT ->
+      case ds1 of {
+        Bin ipv2 ipv3 ipv4 ipv5 ipv6 ->
+          case ds2 of wild1 {
+            Left a2 ->
+              case ipv3 of {
+                Left b2 ->
+                  case a2 of { I# x# ->
+                  case b2 of { I# y# ->
+                  case <# x# y# of {
+                    __DEFAULT ->
+                      case ==# x# y# of {
+                        __DEFAULT ->
+                          $w$sgo15
+                            (or# (uncheckedShiftRL# ww 1#) 9223372036854775808##)
+                            (or# (uncheckedShiftRL# ww1 1#) (uncheckedShiftL# ww 63#))
+                            wild1
+                            ipv6;
+                        1# ->
+                          case ww1 of ds3 {
+                            __DEFAULT ->
+                              let {
+                                hi1 = or# (uncheckedShiftRL# ww 1#) 9223372036854775808## } in
+                              let { zeros = word2Int# (ctz# ds3) } in
+                              (# Just ipv4, uncheckedShiftRL# hi1 zeros,
+                                 or#
+                                   (uncheckedShiftRL#
+                                      (or# (uncheckedShiftRL# ds3 1#) (uncheckedShiftL# ww 63#))
+                                      zeros)
+                                   (uncheckedShiftL# hi1 (-# 64# zeros)) #);
+                            0## ->
+                              (# Just ipv4, 0##,
+                                 uncheckedShiftRL#
+                                   (or# (uncheckedShiftRL# ww 1#) 9223372036854775808##)
+                                   (word2Int# (ctz# ww)) #)
+                          }
+                      };
+                    1# ->
+                      $w$sgo15
+                        (uncheckedShiftRL# ww 1#)
+                        (or# (uncheckedShiftRL# ww1 1#) (uncheckedShiftL# ww 63#))
+                        wild1
+                        ipv5
+                  }
+                  }
+                  };
+                Right ipv ->
+                  $w$sgo15
+                    (uncheckedShiftRL# ww 1#)
+                    (or# (uncheckedShiftRL# ww1 1#) (uncheckedShiftL# ww 63#))
+                    wild1
+                    ipv5
+              };
+            Right a2 ->
+              case ipv3 of {
+                Left ipv ->
+                  $w$sgo15
+                    (or# (uncheckedShiftRL# ww 1#) 9223372036854775808##)
+                    (or# (uncheckedShiftRL# ww1 1#) (uncheckedShiftL# ww 63#))
+                    wild1
+                    ipv6;
+                Right b2 ->
+                  case a2 of { C# x ->
+                  case b2 of { C# y ->
+                  case eqChar# x y of {
+                    __DEFAULT ->
+                      case leChar# x y of {
+                        __DEFAULT ->
+                          $w$sgo15
+                            (or# (uncheckedShiftRL# ww 1#) 9223372036854775808##)
+                            (or# (uncheckedShiftRL# ww1 1#) (uncheckedShiftL# ww 63#))
+                            wild1
+                            ipv6;
+                        1# ->
+                          $w$sgo15
+                            (uncheckedShiftRL# ww 1#)
+                            (or# (uncheckedShiftRL# ww1 1#) (uncheckedShiftL# ww 63#))
+                            wild1
+                            ipv5
+                      };
+                    1# ->
+                      case ww1 of ds3 {
+                        __DEFAULT ->
+                          let {
+                            hi1 = or# (uncheckedShiftRL# ww 1#) 9223372036854775808## } in
+                          let { zeros = word2Int# (ctz# ds3) } in
+                          (# Just ipv4, uncheckedShiftRL# hi1 zeros,
+                             or#
+                               (uncheckedShiftRL#
+                                  (or# (uncheckedShiftRL# ds3 1#) (uncheckedShiftL# ww 63#)) zeros)
+                               (uncheckedShiftL# hi1 (-# 64# zeros)) #);
+                        0## ->
+                          (# Just ipv4, 0##,
+                             uncheckedShiftRL#
+                               (or# (uncheckedShiftRL# ww 1#) 9223372036854775808##)
+                               (word2Int# (ctz# ww)) #)
+                      }
+                  }
+                  }
+                  }
+              }
+          };
+        Tip ->
+          case ww1 of ds3 {
+            __DEFAULT ->
+              let {
+                hi1 = or# (uncheckedShiftRL# ww 1#) 9223372036854775808## } in
+              let { zeros = word2Int# (ctz# ds3) } in
+              (# Nothing, uncheckedShiftRL# hi1 zeros,
+                 or#
+                   (uncheckedShiftRL#
+                      (or# (uncheckedShiftRL# ds3 1#) (uncheckedShiftL# ww 63#)) zeros)
+                   (uncheckedShiftL# hi1 (-# 64# zeros)) #);
+            0## ->
+              (# Nothing, 0##,
+                 uncheckedShiftRL#
+                   (or# (uncheckedShiftRL# ww 1#) 9223372036854775808##)
+                   (word2Int# (ctz# ww)) #)
+          }
+      }
+      }
+end Rec }
+
+$salterF
+  = \ @v @a f1 k1 m ->
+      case $w$sgo15 9223372036854775808## 0## k1 m of
+      { (# ww, ww1, ww2 #) ->
+      case f1 ww of {
+        NotFound -> NotFound;
+        Found a1 a2 ->
+          Found
+            a1
+            (case a2 of {
+               Nothing ->
+                 case ww of {
+                   Nothing -> m;
+                   Just old -> case $wbogus (##) of { __DEFAULT -> $wgo ww1 ww2 m }
+                 };
+               Just new ->
+                 case new of new1 { __DEFAULT ->
+                 case ww of {
+                   Nothing -> $winsertAlong ww1 ww2 k1 new1 m;
+                   Just ds -> $wreplaceAlong ww1 ww2 new1 m
+                 }
+                 }
+             })
+      }
+      }
+
+lvl
+  = \ @v ds ->
+      case ds of {
+        Nothing -> NotFound;
+        Just t -> case t of conrep { __DEFAULT -> Found conrep Nothing }
+      }
+
+Rec {
+$wfoo
+  = \ @v x subst ->
+      case $salterF lvl x subst of {
+        NotFound ->
+          case x of wild1 {
+            Left x1 -> $wfoo wild1 subst;
+            Right y ->
+              $wfoo
+                (Right
+                   (case y of { C# c# ->
+                    let { i# = +# (ord# c#) 1# } in
+                    case leWord# (int2Word# i#) 1114111## of {
+                      __DEFAULT -> $wlvl i#;
+                      1# -> C# (chr# i#)
+                    }
+                    }))
+                subst
+          };
+        Found p q -> (# p, q #)
+      }
+end Rec }
+
+foo
+  = \ @v x subst ->
+      case $wfoo x subst of { (# ww, ww1 #) -> Just (ww, ww1) }
+
+$trModule4 = "main"#
+
+$trModule3 = TrNameS $trModule4
+
+$trModule2 = "T22611"#
+
+$trModule1 = TrNameS $trModule2
+
+$trModule = Module $trModule3 $trModule1
+
+$krep = KindRepVar 1#
+
+$krep1 = KindRepVar 0#
+
+$tcCheckRes2 = "CheckRes"#
+
+$tcCheckRes1 = TrNameS $tcCheckRes2
+
+$tcCheckRes
+  = TyCon
+      2720702776801478797#Word64
+      9603347784695333983#Word64
+      $trModule
+      $tcCheckRes1
+      0#
+      krep$*->*->*
+
+$krep2 = : $krep []
+
+$krep3 = : $krep1 $krep2
+
+$tc'NotFound1 = KindRepTyConApp $tcCheckRes $krep3
+
+$tc'NotFound3 = "'NotFound"#
+
+$tc'NotFound2 = TrNameS $tc'NotFound3
+
+$tc'NotFound
+  = TyCon
+      11874520794839816490#Word64
+      7404827959462889921#Word64
+      $trModule
+      $tc'NotFound2
+      2#
+      $tc'NotFound1
+
+$krep4 = KindRepFun $krep $tc'NotFound1
+
+$tc'Found1 = KindRepFun $krep1 $krep4
+
+$tc'Found3 = "'Found"#
+
+$tc'Found2 = TrNameS $tc'Found3
+
+$tc'Found
+  = TyCon
+      14824125456853884021#Word64
+      17338070180827954559#Word64
+      $trModule
+      $tc'Found2
+      2#
+      $tc'Found1
+
+
+------ Local rules for imported ids --------
+"SPEC/T22611 alterF @(CheckRes v) @(Either Int Char) @_" [2]
+    forall @v @a $dFunctor $dOrd. alterF $dFunctor $dOrd = $salterF
+
+
diff --git a/testsuite/tests/simplCore/should_compile/all.T b/testsuite/tests/simplCore/should_compile/all.T
index 4fd57c5301..08fcb7760f 100644
--- a/testsuite/tests/simplCore/should_compile/all.T
+++ b/testsuite/tests/simplCore/should_compile/all.T
@@ -464,3 +464,5 @@ test('T22623', normal, multimod_compile, ['T22623', '-O -v0'])
 test('T22662', normal, compile, [''])
 test('T22725', normal, compile, ['-O'])
 test('T22502', normal, compile, ['-O'])
+test('T22611', [when(wordsize(32), skip), grep_errmsg(r'\$salterF') ], compile, ['-O -ddump-simpl -dsuppress-uniques -dsuppress-all'])
+