[Git][ghc/ghc][master] Add a test for #21348

[Marge Bot (@marge-bot)]

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


Commits:
242102f4 by Krzysztof Gogolewski at 2023-10-05T05:37:26-04:00
Add a test for #21348

- - - - -


2 changed files:

- + testsuite/tests/simplCore/should_compile/T21348.hs
- testsuite/tests/simplCore/should_compile/all.T


Changes:

=====================================
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


=====================================
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'])



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/242102f4e7631ef47bfb5219355ecf8aad4bc842

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/242102f4e7631ef47bfb5219355ecf8aad4bc842
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/20231005/44b69e50/attachment-0001.html>