diff --git a/testsuite/tests/simplCore/should_compile/T21348.hs b/testsuite/tests/simplCore/should_compile/T21348.hs
new file mode 100644
index 0000000000000000000000000000000000000000..6f723a4a9f5920ebbc0404450809c1bd979f93b0
--- /dev/null
+++ b/testsuite/tests/simplCore/should_compile/T21348.hs
@@ -0,0 +1,97 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+module T21348 where
+
+import qualified Data.Map as M
+import Data.Kind (Type)
+
+newtype Parser a = Parser {
+      runParser :: () -> (a -> Int) -> Int
+    } deriving (Functor)
+
+instance Applicative Parser where
+    pure a = Parser $ \_path ks -> ks a
+    {-# INLINE pure #-}
+    (<*>) m e = Parser $ \path ks -> let ks' a = runParser (a <$> e) path ks
+                                     in runParser m path ks'
+    {-# INLINE (<*>) #-}
+
+data Value = Object (M.Map String Value) | Unused
+
+class FromJSON a where
+    parseJSON :: Value -> Parser a
+    _unused :: a -> a
+
+instance FromJSON Bool where
+    parseJSON _ = pure False
+    _unused = id
+
+data Pa a = MkPa Bool a
+
+class RecordFromJSON f where
+    recordParseJSON :: () -> M.Map String Value -> Parser (Pa f)
+
+class RecordFromJSON2 f where
+    recordParseJSON2 :: M.Map String Value -> Parser f
+
+instance (RecordFromJSON2 b) => RecordFromJSON b where
+    recordParseJSON _ obj = MkPa <$> pure False
+                                 <*> recordParseJSON2 obj
+    {-# INLINE recordParseJSON #-}
+
+instance (FromJSON a) => RecordFromJSON2 a  where
+    recordParseJSON2 obj = pure () *> (id <$> (id <$> parseJSON (obj M.! "x")))
+    {-# INLINE recordParseJSON2 #-}
+
+data Rec :: [Type] -> Type where
+  RNil :: Rec '[]
+  RCons :: Field r -> Rec rs -> Rec (r ': rs)
+
+data Rec2 :: [Type] -> Type where
+  RNil2 :: Rec2 '[]
+  RCons2 :: DocField r -> Rec2 rs -> Rec2 (r ': rs)
+
+data Field x = Field x
+
+newtype DocField x = DocField (Field x)
+
+instance FromJSON (Rec '[]) where
+  parseJSON _ = undefined
+  _unused = id
+
+instance (FromJSON t, FromJSON (Rec rs)) => FromJSON (Rec (t ': rs)) where
+  parseJSON v = rebuild <$> parseJSON v <*> parseJSON v
+    where rebuild m rest = Field m `RCons` rest
+  _unused = id
+
+instance (RMap rs, FromJSON (Rec rs)) => FromJSON (Rec2 rs) where
+  parseJSON v = rmap DocField <$> parseJSON v
+  _unused = id
+
+class RMap rs where
+  rmap :: (forall x. Field x -> DocField x) -> Rec rs -> Rec2 rs
+
+instance RMap '[] where
+  rmap _ RNil = RNil2
+  {-# INLINE rmap #-}
+
+instance RMap xs => RMap (x ': xs) where
+  rmap f (x `RCons` xs) = f x `RCons2` rmap f xs
+  {-# INLINE rmap #-}
+
+g :: RecordFromJSON a => Value -> Parser (Pa a)
+g (Object r) = recordParseJSON () r
+g Unused = undefined
+
+bug :: Value -> Parser (Pa (Rec2 '[Bool, Bool, Bool, Bool]))
+bug = g
diff --git a/testsuite/tests/simplCore/should_compile/all.T b/testsuite/tests/simplCore/should_compile/all.T
index 553861f5b198f441ba4723d22c1efe4df09a686a..1c8450caf9e05d8d8ccd32747d0f1543ca484953 100644
--- a/testsuite/tests/simplCore/should_compile/all.T
+++ b/testsuite/tests/simplCore/should_compile/all.T
@@ -503,3 +503,4 @@ test('T23922a', normal, compile, ['-O'])
 test('T23952', [extra_files(['T23952a.hs'])], multimod_compile, ['T23952', '-v0 -O'])
 test('T24014', normal, compile, ['-dcore-lint'])
 test('T24029', normal, compile, [''])
+test('T21348', normal, compile, ['-O'])