Add more instances, mostly Read and Ord

Also some helper functions, for when the functor variants of type classes aren’t flexible enough.
sellout · Mar 9, 2024 · fd28f56 · fd28f56
1 parent 803875e
commit fd28f56
Show file tree

Hide file tree

Showing 16 changed files with 778 additions and 188 deletions.
diff --git a/containers/src/Yaya/Containers/Pattern/IntMap.hs b/containers/src/Yaya/Containers/Pattern/IntMap.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE CPP #-}
 {-# LANGUAGE Safe #-}
 {-# OPTIONS_GHC -Wno-orphans #-}
 
@@ -6,33 +7,53 @@ module Yaya.Containers.Pattern.IntMap
   )
 where
 
+import "base" Control.Applicative (Alternative ((<|>)), Applicative ((<*>)), (*>))
 import "base" Control.Category (Category ((.)))
 import "base" Data.Bool (Bool (False, True), (&&))
 import "base" Data.Eq (Eq ((==)))
 import "base" Data.Foldable (Foldable)
 import "base" Data.Function (($))
-import "base" Data.Functor (Functor (fmap))
-import "base" Data.Functor.Classes
-  ( Eq1 (liftEq),
-    Eq2 (liftEq2),
-    Ord1 (liftCompare),
-    Ord2 (liftCompare2),
-    Show1 (liftShowsPrec),
-    Show2 (liftShowsPrec2),
-  )
+import "base" Data.Functor (Functor (fmap), (<$), (<$>))
 import "base" Data.Ord (Ord (compare, (<=)), Ordering (EQ, GT, LT))
 import "base" Data.Semigroup ((<>))
 import "base" Data.Traversable (Traversable)
 import qualified "base" Data.Tuple as Tuple
 import "base" GHC.Generics (Generic, Generic1)
-import "base" Text.Show (Show (showList, showsPrec), showParen, showString)
+import "base" GHC.Read (Read (readListPrec, readPrec), expectP, parens)
+import "base" Text.ParserCombinators.ReadPrec (prec, step)
+import qualified "base" Text.Read.Lex as Lex
 import qualified "containers" Data.IntMap.Internal as IntMap
 import "yaya" Yaya.Fold
   ( Projectable (project),
     Recursive (cata),
     Steppable (embed),
   )
 import "base" Prelude (Num ((+)))
+#if MIN_VERSION_base(4, 18, 0)
+import "base" Data.Functor.Classes
+  ( Eq1,
+    Eq2 (liftEq2),
+    Ord2 (liftCompare2),
+    Ord1,
+    Read1 (liftReadPrec),
+    Read2 (liftReadPrec2),
+    Show1,
+    Show2 (liftShowsPrec2),
+  )
+import "base" Text.Show (Show (showsPrec), showParen, showString)
+#else
+import "base" Data.Functor.Classes
+  ( Eq1 (liftEq),
+    Eq2 (liftEq2),
+    Ord1 (liftCompare),
+    Ord2 (liftCompare2),
+    Read1 (liftReadPrec),
+    Read2 (liftReadPrec2),
+    Show1 (liftShowsPrec),
+    Show2 (liftShowsPrec2),
+  )
+import "base" Text.Show (Show (showList, showsPrec), showParen, showString)
+#endif
 
 data IntMapF a r
   = NilF
@@ -42,6 +63,8 @@ data IntMapF a r
     ( Eq,
       Ord,
       Generic,
+      -- | @since 0.1.1.0
+      Read,
       Show,
       Foldable,
       Functor,
@@ -62,10 +85,12 @@ instance Steppable (->) (IntMap.IntMap a) (IntMapF a) where
   embed (TipF key a) = IntMap.Tip key a
   embed (BinF prefix mask l r) = IntMap.Bin prefix mask l r
 
+#if MIN_VERSION_base(4, 18, 0)
+instance (Eq a) => Eq1 (IntMapF a)
+#else
 instance (Eq a) => Eq1 (IntMapF a) where
-  -- TODO: Remove this once base-4.18 is the oldest supported verson, as it’s
-  --       the default impl.
   liftEq = liftEq2 (==)
+#endif
 
 instance Eq2 IntMapF where
   liftEq2 f g = Tuple.curry $ \case
@@ -75,10 +100,12 @@ instance Eq2 IntMapF where
       prefix == prefix' && mask == mask' && g l l' && g r r'
     (_, _) -> False
 
+#if MIN_VERSION_base(4, 18, 0)
+instance (Ord a) => Ord1 (IntMapF a)
+#else
 instance (Ord a) => Ord1 (IntMapF a) where
-  -- TODO: Remove this once base-4.18 is the oldest supported verson, as it’s
-  --       the default impl.
   liftCompare = liftCompare2 compare
+#endif
 
 instance Ord2 IntMapF where
   liftCompare2 f g = Tuple.curry $ \case
@@ -91,25 +118,48 @@ instance Ord2 IntMapF where
       compare prefix prefix' <> compare mask mask' <> g l l' <> g r r'
     (BinF {}, _) -> GT
 
+-- | @since 0.1.1.0
+instance (Read a) => Read1 (IntMapF a) where
+  liftReadPrec = liftReadPrec2 readPrec readListPrec
+
+-- | @since 0.1.1.0
+instance Read2 IntMapF where
+  liftReadPrec2 readPrecA _ readPrecR _ =
+    let appPrec = 10
+     in parens . prec appPrec $
+          NilF
+            <$ expectP (Lex.Ident "NilF")
+            <|> expectP (Lex.Ident "TipF")
+              *> (TipF <$> step readPrec <*> step readPrecA)
+            <|> expectP (Lex.Ident "BinF")
+              *> ( BinF
+                     <$> step readPrec
+                     <*> step readPrec
+                     <*> step readPrecR
+                     <*> step readPrecR
+                 )
+
+#if MIN_VERSION_base(4, 18, 0)
+instance (Show a) => Show1 (IntMapF a)
+#else
 instance (Show a) => Show1 (IntMapF a) where
-  -- TODO: Remove this once base-4.18 is the oldest supported verson, as it’s
-  --       the default impl.
   liftShowsPrec = liftShowsPrec2 showsPrec showList
+#endif
 
 instance Show2 IntMapF where
-  liftShowsPrec2 showsPrecA _showListA showsPrecR _showListR prec =
+  liftShowsPrec2 showsPrecA _ showsPrecR _ p =
     let appPrec = 10
         nextPrec = appPrec + 1
      in \case
           NilF -> showString "NilF"
           TipF key a ->
-            showParen (nextPrec <= prec) $
-              showString "BipF "
+            showParen (nextPrec <= p) $
+              showString "TipF "
                 . showsPrec nextPrec key
                 . showString " "
                 . showsPrecA nextPrec a
           BinF prefix mask l r ->
-            showParen (nextPrec <= prec) $
+            showParen (nextPrec <= p) $
               showString "BinF "
                 . showsPrec nextPrec prefix
                 . showString " "

diff --git a/containers/src/Yaya/Containers/Pattern/IntSet.hs b/containers/src/Yaya/Containers/Pattern/IntSet.hs
@@ -6,22 +6,31 @@ module Yaya.Containers.Pattern.IntSet
   )
 where
 
+import "base" Control.Applicative
+  ( Alternative ((<|>)),
+    Applicative ((<*>)),
+    (*>),
+  )
 import "base" Control.Category (Category ((.)))
 import "base" Data.Bool (Bool (False, True), (&&))
 import "base" Data.Eq (Eq ((==)))
 import "base" Data.Foldable (Foldable)
 import "base" Data.Function (($))
-import "base" Data.Functor (Functor (fmap))
+import "base" Data.Functor (Functor (fmap), (<$), (<$>))
 import "base" Data.Functor.Classes
   ( Eq1 (liftEq),
     Ord1 (liftCompare),
+    Read1 (liftReadPrec),
     Show1 (liftShowsPrec),
   )
 import "base" Data.Ord (Ord (compare, (<=)), Ordering (EQ, GT, LT))
 import "base" Data.Semigroup ((<>))
 import "base" Data.Traversable (Traversable)
 import qualified "base" Data.Tuple as Tuple
 import "base" GHC.Generics (Generic, Generic1)
+import "base" GHC.Read (Read (readPrec), expectP, parens)
+import "base" Text.ParserCombinators.ReadPrec (prec, step)
+import qualified "base" Text.Read.Lex as Lex
 import "base" Text.Show (Show (showsPrec), showParen, showString)
 import qualified "containers" Data.IntSet.Internal as IntSet
 import "yaya" Yaya.Fold
@@ -39,6 +48,8 @@ data IntSetF r
     ( Eq,
       Ord,
       Generic,
+      -- | @since 0.1.1.0
+      Read,
       Show,
       Foldable,
       Functor,
@@ -79,20 +90,37 @@ instance Ord1 IntSetF where
       compare prefix prefix' <> compare mask mask' <> f l l' <> f r r'
     (BinF {}, _) -> GT
 
+-- | @since 0.1.1.0
+instance Read1 IntSetF where
+  liftReadPrec readPrecR _ =
+    let appPrec = 10
+     in parens . prec appPrec $
+          NilF
+            <$ expectP (Lex.Ident "NilF")
+            <|> expectP (Lex.Ident "TipF")
+              *> (TipF <$> step readPrec <*> step readPrec)
+            <|> expectP (Lex.Ident "BinF")
+              *> ( BinF
+                     <$> step readPrec
+                     <*> step readPrec
+                     <*> step readPrecR
+                     <*> step readPrecR
+                 )
+
 instance Show1 IntSetF where
-  liftShowsPrec showsPrecR _showListR prec =
+  liftShowsPrec showsPrecR _ p =
     let appPrec = 10
         nextPrec = appPrec + 1
      in \case
           NilF -> showString "NilF"
           TipF prefix bm ->
-            showParen (nextPrec <= prec) $
+            showParen (nextPrec <= p) $
               showString "TipF "
                 . showsPrec nextPrec prefix
                 . showString " "
                 . showsPrec nextPrec bm
           BinF prefix mask l r ->
-            showParen (nextPrec <= prec) $
+            showParen (nextPrec <= p) $
               showString "BinF "
                 . showsPrec nextPrec prefix
                 . showString " "