From b99e5b7f2a383238afbc018187b2062a2514f2f8 Mon Sep 17 00:00:00 2001 From: Matthew Pickering Date: Wed, 27 Apr 2022 17:24:45 +0100 Subject: Add test for T21229 --- testsuite/tests/simplCore/should_run/T21229.hs | 24 ++++++++++++++++++++++ testsuite/tests/simplCore/should_run/T21229.stdout | 1 + testsuite/tests/simplCore/should_run/all.T | 1 + 3 files changed, 26 insertions(+) create mode 100644 testsuite/tests/simplCore/should_run/T21229.hs create mode 100644 testsuite/tests/simplCore/should_run/T21229.stdout diff --git a/testsuite/tests/simplCore/should_run/T21229.hs b/testsuite/tests/simplCore/should_run/T21229.hs new file mode 100644 index 0000000000..c5e22f6773 --- /dev/null +++ b/testsuite/tests/simplCore/should_run/T21229.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE KindSignatures #-} +module Main where + +data B = T | F deriving Show + +class Sing (b :: B) where sing :: B +instance Sing 'T where sing = T +instance Sing 'F where sing = F + +f :: forall a. Sing a => Int -> (Int -> B -> B) -> B +f 0 g = g 0 (sing @a) +f n g = f @a (n-1) g + +h :: forall a. Sing a => Int -> (Int -> B -> B) -> B +h = case sing @a of + T -> f @'T + F -> f @a +{-# NOINLINE h #-} + +main = print $ h @'T 0 (\ _ a -> a) diff --git a/testsuite/tests/simplCore/should_run/T21229.stdout b/testsuite/tests/simplCore/should_run/T21229.stdout new file mode 100644 index 0000000000..62a6e3c9df --- /dev/null +++ b/testsuite/tests/simplCore/should_run/T21229.stdout @@ -0,0 +1 @@ +T diff --git a/testsuite/tests/simplCore/should_run/all.T b/testsuite/tests/simplCore/should_run/all.T index 54ec5b8bff..34e7e2e386 100644 --- a/testsuite/tests/simplCore/should_run/all.T +++ b/testsuite/tests/simplCore/should_run/all.T @@ -101,3 +101,4 @@ test('T19569', [only_ways(['optasm']),extra_run_opts('True 1000000')], compile_a test('T20203', normal, compile, ['-O -dsuppress-all -dsuppress-uniques -dno-typeable-binds -ddump-simpl']) test('T19313', normal, compile_and_run, ['']) test('UnliftedArgRule', normal, compile_and_run, ['']) +test('T21229', normal, compile_and_run, ['-O']) -- cgit v1.2.1