Add more instances, mostly Read and Ord (#39)

Also some helper functions, for when the functor variants of type classes aren’t flexible enough.
sellout · Mar 26, 2024 · 1a88688 · 1a88688
2 parents 1faa456 + cb04255
commit 1a88688
Show file tree

Hide file tree

Showing 22 changed files with 927 additions and 223 deletions.
diff --git a/.config/mustache.yaml b/.config/mustache.yaml
@@ -1,8 +1,11 @@
-{"project":{
-  "description":"Total recursion scheme library for Haskell.",
-  "name":"yaya",
-  "repo":"sellout/yaya",
-  "summary":"Yet another … yet another recursion scheme library for Haskell",
-  "version":"0.1.0.0"},
-  "type":{"name":"haskell"}
-  }
+{
+  "project":
+    {
+      "description": "Total recursion scheme library for Haskell.",
+      "name": "yaya",
+      "repo": "sellout/yaya",
+      "summary": "Yet another … yet another recursion scheme library for Haskell",
+      "version": "0.1.0.0",
+    },
+  "type": { "name": "haskell" },
+}
diff --git a/.config/project/github-ci.nix b/.config/project/github-ci.nix
@@ -94,7 +94,16 @@ in {
               cabal-version = pkgs.cabal-install.version;
             };
           }
-          {run = "cabal install cabal-plan-bounds";}
+          {
+            run = ''
+              ## TODO: Remove the manual cloning once cabal-plan-bounds >0.1.5.1
+              ##       is released. Currently, it’s needed because of
+              ##       nomeata/cabal-plan-bounds#19.
+              git clone https://github.com/nomeata/cabal-plan-bounds
+              cd cabal-plan-bounds
+              cabal install cabal-plan-bounds
+            '';
+          }
           {
             name = "download Cabal plans";
             uses = "actions/download-artifact@v4";
@@ -113,9 +122,16 @@ in {
             ## TODO: Simplify this once cabal-plan-bounds supports a `--check`
             ##       option.
             run = ''
-              diffs="$(find . \
-                -name '*.cabal' \
-                -exec cabal-plan-bounds --dry-run plans/*.json --cabal {} \;)"
+              diffs="$(find . -name '*.cabal' -exec \
+                cabal-plan-bounds \
+                  --dry-run \
+                  ${
+                lib.concatMapStrings
+                (pkg: "--also " + pkg + " ")
+                self.lib.extraDependencyVersions
+              } \
+                  plans/*.json \
+                  --cabal {} \;)"
               if [[ -n "$diffs" ]]; then
                 echo "$diffs"
                 exit 1

diff --git a/.config/project/hlint.nix b/.config/project/hlint.nix
@@ -1,12 +1,31 @@
-{lib, pkgs, ...}: {
+{
+  lib,
+  pkgs,
+  ...
+}: {
   ## Haskell linter
   programs.treefmt.programs.hlint.enable = true;
   ## TODO: Wrap this to find our generated hlint config in the store.
   project.devPackages = [pkgs.hlint];
   project.file.".hlint.yaml".text = lib.generators.toYAML {} [
-    {group = {name = "dollar"; enabled = true;};}
-    {group = {name = "future"; enabled = true;};}
-    {group = {name = "generalise"; enabled = true;};}
+    {
+      group = {
+        name = "dollar";
+        enabled = true;
+      };
+    }
+    {
+      group = {
+        name = "future";
+        enabled = true;
+      };
+    }
+    {
+      group = {
+        name = "generalise";
+        enabled = true;
+      };
+    }
 
     {ignore = {name = "Eta reduce";};}
     {ignore = {name = "Evaluate";};}
@@ -39,14 +58,54 @@
           "package traversable"
         ];
         rules = [
-          {warn = {lhs = "forM"; rhs = "for";};}
-          {warn = {lhs = "forM_"; rhs = "for_";};}
-          {warn = {lhs = "map"; rhs = "fmap";};}
-          {warn = {lhs = "mapM"; rhs = "traverse";};}
-          {warn = {lhs = "mapM_"; rhs = "traverse_";};}
-          {warn = {lhs = "return"; rhs = "pure";};}
-          {warn = {lhs = "sequence"; rhs = "sequenceA";};}
-          {warn = {lhs = "sequence_"; rhs = "sequenceA_";};}
+          {
+            warn = {
+              lhs = "forM";
+              rhs = "for";
+            };
+          }
+          {
+            warn = {
+              lhs = "forM_";
+              rhs = "for_";
+            };
+          }
+          {
+            warn = {
+              lhs = "map";
+              rhs = "fmap";
+            };
+          }
+          {
+            warn = {
+              lhs = "mapM";
+              rhs = "traverse";
+            };
+          }
+          {
+            warn = {
+              lhs = "mapM_";
+              rhs = "traverse_";
+            };
+          }
+          {
+            warn = {
+              lhs = "return";
+              rhs = "pure";
+            };
+          }
+          {
+            warn = {
+              lhs = "sequence";
+              rhs = "sequenceA";
+            };
+          }
+          {
+            warn = {
+              lhs = "sequence_";
+              rhs = "sequenceA_";
+            };
+          }
         ];
       };
     }
@@ -63,8 +122,18 @@
               note = "IncreasesLaziness";
             };
           }
-          {warn = {lhs = "mappend"; rhs = "(<>)";};}
-          {warn = {lhs = "(++)"; rhs = "(<>)";};}
+          {
+            warn = {
+              lhs = "mappend";
+              rhs = "(<>)";
+            };
+          }
+          {
+            warn = {
+              lhs = "(++)";
+              rhs = "(<>)";
+            };
+          }
         ];
       };
     }

diff --git a/.github/workflows/build.yml b/.github/workflows/build.yml
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.2.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.2.0
+instance (Read a) => Read1 (IntMapF a) where
+  liftReadPrec = liftReadPrec2 readPrec readListPrec
+
+-- | @since 0.1.2.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 " "