Add test for #16893wip/T16893-8.8

3 files changed, 93 insertions, 0 deletions

diff --git a/testsuite/tests/simplCore/should_run/T16893/Complex.hs b/testsuite/tests/simplCore/should_run/T16893/Complex.hs
new file mode 100644
index 0000000000..994ea73ed3
--- /dev/null
+++ b/testsuite/tests/simplCore/should_run/T16893/Complex.hs
@@ -0,0 +1,68 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
+
+module Complex
+  ( Type(..)
+  , OpenComplex(..)
+  , CloseComplex(..)
+  , Complex(..)
+  , closeComplex
+  ) where
+
+import Data.ByteString as B
+import Data.ByteString.Short as BS
+import Data.Typeable
+
+data Type
+  = OpenType
+  | CloseType
+
+data OpenComplex = OpenComplex
+  { openComplexSource :: ByteString
+  }
+
+data CloseComplex = CloseComplex
+  { closeComplexHash   :: ByteString
+  , closeComplexSource :: !ByteString
+  }
+
+data Complex (t :: Type) = Complex
+  { complexInner   :: !(ComplexFamily t)
+  }
+
+type family ComplexFamily (t :: Type) where
+  ComplexFamily 'OpenType    = OpenComplex
+  ComplexFamily 'CloseType = CloseComplex
+
+handleComplex ::
+     forall t a. Typeable t
+  => Complex t
+  -> (Complex 'CloseType -> a)
+  -> a
+handleComplex complex onClose =
+  case toCloseComplex complex of
+    Just receiveComplex -> onClose receiveComplex
+    Nothing             -> undefined
+
+toCloseComplex ::
+     forall t. Typeable t
+  => Complex t
+  -> Maybe (Complex 'CloseType)
+toCloseComplex x = fmap (\Refl -> x) (eqT :: Maybe (t :~: 'CloseType))
+
+closeComplex :: Typeable t => Complex t -> Close
+closeComplex complex =
+  handleComplex
+    complex
+    receiveComplexToProtocolCloseComplex
+
+receiveComplexToProtocolCloseComplex :: Complex 'CloseType -> Close
+receiveComplexToProtocolCloseComplex Complex {complexInner = inner} =
+  Close (hashToLink (closeComplexSource inner))
+
+data Close = Close !ShortByteString
+
+hashToLink :: ByteString -> ShortByteString
+hashToLink bh = BS.toShort bh
diff --git a/testsuite/tests/simplCore/should_run/T16893/T16893.hs b/testsuite/tests/simplCore/should_run/T16893/T16893.hs
new file mode 100644
index 0000000000..5dd8fdf568
--- /dev/null
+++ b/testsuite/tests/simplCore/should_run/T16893/T16893.hs
@@ -0,0 +1,21 @@
+{-# LANGUAGE DataKinds #-}
+
+module Main (main) where
+
+import Complex
+
+badComplex :: Complex 'OpenType
+badComplex =
+  Complex
+    { complexInner =
+        OpenComplex
+          { openComplexSource = undefined
+          }
+    }
+
+segFaultTrigger :: IO ()
+segFaultTrigger =
+  closeComplex badComplex `seq` pure ()
+
+main :: IO ()
+main = segFaultTrigger
diff --git a/testsuite/tests/simplCore/should_run/T16893/all.T b/testsuite/tests/simplCore/should_run/T16893/all.T
new file mode 100644
index 0000000000..0ef2f5219e
--- /dev/null
+++ b/testsuite/tests/simplCore/should_run/T16893/all.T
@@ -0,0 +1,4 @@
+test('T16893',
+     [expect_broken(16893), extra_files(['Complex.hs'])],
+     compile_and_run,
+     ['-O1'])