From 242102f4e7631ef47bfb5219355ecf8aad4bc842 Mon Sep 17 00:00:00 2001
From: Krzysztof Gogolewski <krzysztof.gogolewski@tweag.io>
Date: Wed, 4 Oct 2023 16:15:30 +0200
Subject: [PATCH] Add a test for #21348
---
.../tests/simplCore/should_compile/T21348.hs | 97 +++++++++++++++++++
.../tests/simplCore/should_compile/all.T | 1 +
2 files changed, 98 insertions(+)
create mode 100644 testsuite/tests/simplCore/should_compile/T21348.hs
diff --git a/testsuite/tests/simplCore/should_compile/T21348.hs b/testsuite/tests/simplCore/should_compile/T21348.hs
new file mode 100644
index 000000000000..6f723a4a9f59
--- /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 553861f5b198..1c8450caf9e0 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'])
--
GitLab