testsuite: Add test for #21583

3 files changed, 113 insertions, 0 deletions

diff --git a/testsuite/tests/typecheck/should_fail/T21583.hs b/testsuite/tests/typecheck/should_fail/T21583.hs
new file mode 100644
index 0000000000..5b7873dce6
--- /dev/null
+++ b/testsuite/tests/typecheck/should_fail/T21583.hs
@@ -0,0 +1,90 @@
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE DeriveTraversable          #-}
+{-# LANGUAGE TypeFamilies               #-}
+{-# LANGUAGE PatternSynonyms            #-}
+{-# LANGUAGE FlexibleContexts #-}
+module Telomare.Possible where
+
+data PartExprF f
+  = ZeroSF
+  deriving (Eq, Ord, Show, Functor, Foldable, Traversable)
+
+newtype EnhancedExpr f = EnhancedExpr {unEnhanceExpr :: SplitFunctor f PartExprF (EnhancedExpr f)} -- deriving (Eq, Show)
+
+type family Base t :: * -> *
+
+type instance Base (EnhancedExpr f) = SplitFunctor f PartExprF
+
+class Functor (Base t) => Recursive t where
+  project :: t -> Base t t
+
+instance Functor f => Recursive (EnhancedExpr f) where
+  project = unEnhanceExpr
+
+class Functor (Base t) => Corecursive t where
+  embed :: Base t t -> t
+
+instance Functor f => Corecursive (EnhancedExpr f) where
+  embed = EnhancedExpr
+
+type SimpleExpr = EnhancedExpr VoidF
+type BasicBase f = SplitFunctor f PartExprF
+type SuperBase f = BasicBase (SplitFunctor f SuperPositionF)
+type AbortBase f = SuperBase (SplitFunctor f AbortableF)
+type UnsizedBase = AbortBase UnsizedRecursionF
+
+pattern UnsizedFW :: UnsizedRecursionF a -> UnsizedBase a
+pattern UnsizedFW x = SplitFunctor (Left (SplitFunctor (Left (SplitFunctor (Left x)))))
+pattern BasicExpr :: PartExprF (EnhancedExpr f) -> EnhancedExpr f
+pattern BasicExpr x = EnhancedExpr (SplitFunctor (Right x))
+pattern UnsizedWrap :: UnsizedRecursionF UnsizedExpr -> UnsizedExpr
+pattern UnsizedWrap x = EnhancedExpr (UnsizedFW x)
+
+data VoidF f
+  deriving (Functor, Foldable, Traversable)
+
+data SuperPositionF f
+  = AnyPF
+  deriving (Eq, Ord, Show, Functor, Foldable, Traversable)
+
+data AbortableF f
+  = AbortF
+  deriving (Eq, Ord, Show, Functor, Foldable, Traversable)
+
+newtype SplitFunctor g f x = SplitFunctor { unSplitF :: Either (g x) (f x) } deriving (Eq, Show)
+
+instance (Functor f, Functor g) => Functor (SplitFunctor g f) where
+
+instance (Foldable f, Foldable g) => Foldable (SplitFunctor g f) where
+
+instance (Traversable f, Traversable g) => Traversable (SplitFunctor g f) where
+
+type SuperExpr f = EnhancedExpr (SplitFunctor f SuperPositionF)
+
+type AbortExpr f = SuperExpr (SplitFunctor f AbortableF)
+
+type BreakExtras = ()
+
+data UnsizedRecursionF f
+  = UnsizedRecursionF BreakExtras f
+  | UnsizedBarrierF f
+  deriving (Eq, Ord, Show, Functor, Foldable, Traversable)
+
+type UnsizedExpr = AbortExpr UnsizedRecursionF
+
+cata :: Recursive t => (Base t a -> a) -> t -> a
+cata = undefined
+
+sizeTerm :: UnsizedExpr -> Maybe (AbortExpr VoidF)
+sizeTerm term =
+  let sizingTerm = eval term
+      eval :: UnsizedExpr -> UnsizedExpr
+      eval = undefined
+      setSizes sizes = cata $ \case
+        UnsizedFW (UnsizedRecursionF be env) -> BasicExpr ZeroSF
+      clean = undefined
+      hoist = undefined
+      maybeSized = pure sizingTerm
+  in hoist clean <$> maybeSized
+
+
diff --git a/testsuite/tests/typecheck/should_fail/T21583.stderr b/testsuite/tests/typecheck/should_fail/T21583.stderr
new file mode 100644
index 0000000000..a250419f09
--- /dev/null
+++ b/testsuite/tests/typecheck/should_fail/T21583.stderr
@@ -0,0 +1,22 @@
+T21583.hs:14:23: error: [-Wstar-is-type (in -Wall, -Wcompat), -Werror=star-is-type]
+    Using ‘*’ (or its Unicode variant) to mean ‘Data.Kind.Type’
+    relies on the StarIsType extension, which will become
+    deprecated in the future.
+    Suggested fix: Use ‘Type’ from ‘Data.Kind’ instead.
+T21583.hs:14:28: error: [-Wstar-is-type (in -Wall, -Wcompat), -Werror=star-is-type]
+    Using ‘*’ (or its Unicode variant) to mean ‘Data.Kind.Type’
+    relies on the StarIsType extension, which will become
+    deprecated in the future.
+    Suggested fix: Use ‘Type’ from ‘Data.Kind’ instead.
+T21583.hs:56:10: warning: [-Wmissing-methods (in -Wdefault)]
+    • No explicit implementation for
+        ‘fmap’
+    • In the instance declaration for ‘Functor (SplitFunctor g f)’
+T21583.hs:58:10: warning: [-Wmissing-methods (in -Wdefault)]
+    • No explicit implementation for
+        either ‘foldMap’ or ‘foldr’
+    • In the instance declaration for ‘Foldable (SplitFunctor g f)’
+T21583.hs:60:10: warning: [-Wmissing-methods (in -Wdefault)]
+    • No explicit implementation for
+        either ‘traverse’ or ‘sequenceA’
+    • In the instance declaration for ‘Traversable (SplitFunctor g f)’
diff --git a/testsuite/tests/typecheck/should_fail/all.T b/testsuite/tests/typecheck/should_fail/all.T
index 457e0c5bc1..2674798823 100644
--- a/testsuite/tests/typecheck/should_fail/all.T
+++ b/testsuite/tests/typecheck/should_fail/all.T
@@ -657,3 +657,4 @@ test('T20768_fail', normal, compile_fail, [''])
 test('T21327', normal, compile_fail, [''])
 test('T21338', normal, compile_fail, [''])
 test('T21158', normal, compile_fail, [''])
+test('T21583', normal, compile_fail, [''])