Restrict (co)recursive instances

containers/src/Yaya/Containers/Pattern/IntMap.hs

@@ -1,5 +1,6 @@
 {-# LANGUAGE CPP #-}
 {-# LANGUAGE Safe #-}
+{-# LANGUAGE TypeFamilies #-}
 {-# OPTIONS_GHC -Wno-orphans #-}
 
 module Yaya.Containers.Pattern.IntMap
@@ -50,16 +51,26 @@ import "yaya" Yaya.Fold
     embed,
     project,
   )
+import "yaya" Yaya.Strict (Strict)
 import qualified "yaya-unsafe" Yaya.Unsafe.Fold as Unsafe
 import "base" Prelude ((+))
 #if MIN_VERSION_containers(0, 8, 0)
 import qualified "containers" Data.IntSet.Internal.IntTreeCommons as IntMap
   ( Prefix (Prefix),
   )
+#endif
+
+type instance Strict IntMap.IntMap = 'False
+
+-- |
+--
+--  __FIXME__: This is strict only if `a` is not non-strict.
+type instance Strict (IntMap.IntMap _a) = 'True
 
 data IntMapF a r
   = NilF
-  | TipF IntMap.Key a
+  | TipF IntMap.Key ~a
+#if MIN_VERSION_containers(0, 8, 0)
   | BinF IntMap.Prefix r r
   deriving stock
     ( Eq,
@@ -70,9 +81,6 @@ data IntMapF a r
       Traversable
     )
 #else
-data IntMapF a r
-  = NilF
-  | TipF IntMap.Key a
   | BinF IntMap.Prefix IntMap.Mask r r
   deriving stock
     ( Eq,
@@ -84,6 +92,18 @@ data IntMapF a r
     )
 #endif
 
+type instance Strict IntMapF = 'False
+
+-- |
+--
+--  __FIXME__: This is strict only if `a` is not non-strict.
+type instance Strict (IntMapF _a) = 'True
+
+-- |
+--
+--  __FIXME__: This is strict only if `a` is not non-strict.
+type instance Strict (IntMapF _a _r) = 'True
+
 instance Projectable (->) (IntMap.IntMap a) (IntMapF a) where
   project = \case
     IntMap.Nil -> NilF

containers/src/Yaya/Containers/Pattern/IntSet.hs

@@ -1,5 +1,6 @@
 {-# LANGUAGE CPP #-}
 {-# LANGUAGE Safe #-}
+{-# LANGUAGE TypeFamilies #-}
 {-# OPTIONS_GHC -Wno-orphans #-}
 
 module Yaya.Containers.Pattern.IntSet
@@ -43,16 +44,21 @@ import "yaya" Yaya.Fold
     embed,
     project,
   )
+import "yaya" Yaya.Strict (Strict)
 import qualified "yaya-unsafe" Yaya.Unsafe.Fold as Unsafe
 import "base" Prelude ((+))
 #if MIN_VERSION_containers(0, 8, 0)
 import qualified "containers" Data.IntSet.Internal.IntTreeCommons as IntSet
   ( Prefix (Prefix),
   )
+#endif
+
+type instance Strict IntSet.IntSet = 'True
 
 data IntSetF r
   = NilF
   | TipF Int IntSet.BitMap
+#if MIN_VERSION_containers(0, 8, 0)
   | BinF IntSet.Prefix r r
   deriving stock
     ( Eq,
@@ -63,9 +69,6 @@ data IntSetF r
       Traversable
     )
 #else
-data IntSetF r
-  = NilF
-  | TipF Int IntSet.BitMap
   | BinF IntSet.Prefix IntSet.Mask r r
   deriving stock
     ( Eq,
@@ -77,6 +80,10 @@ data IntSetF r
     )
 #endif
 
+type instance Strict IntSetF = 'True
+
+type instance Strict (IntSetF _r) = 'True
+
 instance Projectable (->) IntSet.IntSet IntSetF where
   project = \case
     IntSet.Nil -> NilF

containers/src/Yaya/Containers/Pattern/Map.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE Safe #-}
+{-# LANGUAGE TypeFamilies #-}
 {-# OPTIONS_GHC -Wno-orphans #-}
 
 module Yaya.Containers.Pattern.Map
@@ -73,9 +74,19 @@ import "yaya" Yaya.Fold
     embed,
     project,
   )
+import "yaya" Yaya.Strict (Strict)
 import qualified "yaya-unsafe" Yaya.Unsafe.Fold as Unsafe
 import "base" Prelude ((+))
 
+type instance Strict Map.Map = 'False
+
+type instance Strict (Map.Map _k) = 'False
+
+-- |
+--
+--  __FIXME__: This is strict only if `v` is not non-strict.
+type instance Strict (Map.Map _k _v) = 'True
+
 data MapF k v r = TipF | BinF Map.Size k ~v r r
   deriving stock
     ( Eq,
@@ -90,6 +101,20 @@ data MapF k v r = TipF | BinF Map.Size k ~v r r
       Traversable
     )
 
+type instance Strict MapF = 'False
+
+type instance Strict (MapF _k) = 'False
+
+-- |
+--
+--  __FIXME__: This is strict only if `v` is not non-strict.
+type instance Strict (MapF _k _v) = 'True
+
+-- |
+--
+--  __FIXME__: This is strict only if `v` is not non-strict.
+type instance Strict (MapF _k _v _r) = 'True
+
 instance Projectable (->) (Map.Map k v) (MapF k v) where
   project Map.Tip = TipF
   project (Map.Bin size k v l r) = BinF size k v l r

containers/src/Yaya/Containers/Pattern/Set.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE Safe #-}
+{-# LANGUAGE TypeFamilies #-}
 {-# OPTIONS_GHC -Wno-orphans #-}
 
 module Yaya.Containers.Pattern.Set
@@ -49,9 +50,14 @@ import "yaya" Yaya.Fold
     embed,
     project,
   )
+import "yaya" Yaya.Strict (Strict)
 import qualified "yaya-unsafe" Yaya.Unsafe.Fold as Unsafe
 import "base" Prelude ((+))
 
+type instance Strict Set.Set = 'True
+
+type instance Strict (Set.Set _a) = 'True
+
 data SetF a r = TipF | BinF Set.Size a r r
   deriving stock
     ( Eq,
@@ -66,6 +72,12 @@ data SetF a r = TipF | BinF Set.Size a r r
       Traversable
     )
 
+type instance Strict SetF = 'True
+
+type instance Strict (SetF _a) = 'True
+
+type instance Strict (SetF _a _r) = 'True
+
 instance Projectable (->) (Set.Set a) (SetF a) where
   project Set.Tip = TipF
   project (Set.Bin size a l r) = BinF size a l r

core/src/Yaya/Applied.hs

@@ -2,6 +2,8 @@
 {-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeFamilies #-}
+-- Needed by `PartialTypeError` constraints in GHC 9.4.
+{-# LANGUAGE UndecidableInstances #-}
 {-# OPTIONS_GHC -Wno-orphans #-}
 {-# OPTIONS_GHC -fplugin-opt=NoRecursion:ignore-methods:sconcat #-}
 
@@ -94,14 +96,15 @@ import safe "this" Yaya.Fold.Common
     truncate',
     unarySequence,
   )
-import safe "this" Yaya.Fold.Native (Fix)
+import safe "this" Yaya.Fold.Native (Cofix, Fix)
 import safe "this" Yaya.Pattern
   ( Either (Left),
     Maybe (Just, Nothing),
     Pair,
     XNor (Both, Neither),
     maybe,
   )
+import safe "this" Yaya.Strict (PartialTypeError, unsatisfiable)
 import safe "base" Prelude (Integral, fromIntegral)
 
 -- See comment on @{-# LANGUAGE Safe #-}@ above.
@@ -308,8 +311,28 @@ fromListN = cata2 (embed . takeAvailable) . fromIntegral @_ @Natural
 toList :: (Projectable (->) t (XNor a)) => t -> [a]
 toList = ana project
 
+-- | This instance is safe, since both structures are lazy.
+instance IsList (Cofix (XNor a)) where
+  type Item (Cofix (XNor a)) = a
+  fromList = fromList
+  fromListN = fromListN
+  toList = toList
+
+instance (PartialTypeError Fix) => IsList (Fix (XNor a)) where
+  type Item (Fix (XNor a)) = a
+  fromList = unsatisfiable
+  fromListN = fromListN
+  toList = toList
+
+instance (PartialTypeError Mu) => IsList (Mu (XNor a)) where
+  type Item (Mu (XNor a)) = a
+  fromList = unsatisfiable
+  fromListN = fromListN
+  toList = toList
+
 -- | This instance is safe, since both structures are lazy.
 instance IsList (Nu (XNor a)) where
   type Item (Nu (XNor a)) = a
   fromList = fromList
+  fromListN = fromListN
   toList = toList