[Git][ghc/ghc][master] testsuite: Add test for #21583

[Marge Bot (@marge-bot)]

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


Commits:
714c936f by Bryan Richter at 2022-08-18T18:37:21-04:00
testsuite: Add test for #21583

- - - - -


3 changed files:

- + testsuite/tests/typecheck/should_fail/T21583.hs
- + testsuite/tests/typecheck/should_fail/T21583.stderr
- testsuite/tests/typecheck/should_fail/all.T


Changes:

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


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


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



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/714c936fa31d83cb46b52d1dd920081474793a71

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/714c936fa31d83cb46b52d1dd920081474793a71
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/20220818/47020670/attachment-0001.html>