[Git][ghc/ghc][master] Add tests for #21973

[Marge Bot (@marge-bot)]

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


Commits:
0baf9e7c by Krzysztof Gogolewski at 2023-06-16T12:26:17-04:00
Add tests for #21973

- - - - -


5 changed files:

- + testsuite/tests/typecheck/should_run/T21973a.hs
- + testsuite/tests/typecheck/should_run/T21973a.stderr
- + testsuite/tests/typecheck/should_run/T21973b.hs
- + testsuite/tests/typecheck/should_run/T21973b.stdout
- testsuite/tests/typecheck/should_run/all.T


Changes:

=====================================
testsuite/tests/typecheck/should_run/T21973a.hs
=====================================
@@ -0,0 +1,45 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE InstanceSigs #-}
+
+module Main (main) where
+
+import Data.Kind
+import GHC.Exts
+
+class (Monoid (Share a), Eq (Share a)) => ClassDecode a where
+  type Share a :: Type
+  decoderWithShare :: Share a -> Decoder a
+
+class (Eq (Currency e), ClassDecode (Tx e)) => ClassLedger e where
+  type Currency e :: Type
+  type Tx e :: Type
+
+newtype Decoder a = Decoder (String -> a)
+
+{-# NOINLINE decode #-}
+decode :: ClassDecode a => String -> a
+decode str =
+  case decoderWithShare mempty of
+    Decoder f -> f str
+
+data MyLedger c
+
+newtype MyTx c = MyTx
+  { currency :: c
+  } deriving (Show, Read)
+
+instance (Eq c) => ClassLedger (MyLedger c) where
+  type Currency (MyLedger c) = c
+  type Tx (MyLedger c) = MyTx c
+
+instance (Eq [c], ClassLedger (MyLedger c)) => ClassDecode (MyTx c) where
+  type Share (MyTx c) = [c]
+  {-# NOINLINE decoderWithShare #-}
+  decoderWithShare :: [c] -> Decoder (MyTx c)
+  decoderWithShare (s :: [c]) =
+    Decoder $ \str -> error $ show (s == s)
+
+main :: IO ()
+main = print (noinline decode (noinline show (currency (MyTx "USD"))) :: MyTx String)


=====================================
testsuite/tests/typecheck/should_run/T21973a.stderr
=====================================
@@ -0,0 +1,3 @@
+T21973a: True
+CallStack (from HasCallStack):
+  error, called at T21973a.hs:42:23 in main:Main


=====================================
testsuite/tests/typecheck/should_run/T21973b.hs
=====================================
@@ -0,0 +1,40 @@
+{-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE InstanceSigs #-}
+
+module Main (main) where
+
+import Data.Kind
+import GHC.Exts
+
+
+data D a = MkD
+  deriving Eq
+
+class Def a where
+  def :: a
+instance Def (D a) where
+  def = MkD
+
+type family Share a where
+  Share Char = Char
+
+
+class ( Share a ~ a, Def a ) => ClassDecode a where
+instance ClassLedger c => ClassDecode (D c) where
+
+class (Eq e, ClassDecode (D e)) => ClassLedger e where
+instance Eq c => ClassLedger c where
+
+
+decoderWithShare2 :: ClassLedger a => a -> Bool
+decoderWithShare2 d = d == d
+
+
+decode :: forall a. (ClassLedger a, ClassDecode a) => Bool
+decode = decoderWithShare2 @a (def @(Share a))
+
+main :: IO ()
+main = print (decode @(D Char))


=====================================
testsuite/tests/typecheck/should_run/T21973b.stdout
=====================================
@@ -0,0 +1 @@
+True


=====================================
testsuite/tests/typecheck/should_run/all.T
=====================================
@@ -167,3 +167,5 @@ test('T19397M4', extra_files(['T19397S.hs']), compile_and_run, ['-main-is foo'])
 test('T19667', normal, compile_and_run, ['-fhpc'])
 test('T20768', normal, compile_and_run, [''])
 test('T22510', normal, compile_and_run, [''])
+test('T21973a', [exit_code(1)], compile_and_run, [''])
+test('T21973b', normal, compile_and_run, [''])



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/0baf9e7cfa5d0e76998c2a528693736a6317cf4c

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/0baf9e7cfa5d0e76998c2a528693736a6317cf4c
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/20230616/70a7679e/attachment-0001.html>