Prepare to release 0.3.1 (#30)

travitch · web-flow · commit 69a67bc3da6a · 2025-08-25T21:50:14.000-06:00
This commit regenerated the CI configuration to use a newer base image. It also cleans up warnings that were causing failures in the GHC CI builds.
diff --git a/.github/workflows/haskell-ci.yml b/.github/workflows/haskell-ci.yml
@@ -8,9 +8,9 @@
 #
 # For more information, see https://github.com/haskell-CI/haskell-ci
 #
-# version: 0.19.20240708
+# version: 0.19.20250801
 #
-# REGENDATA ("0.19.20240708",["github","haggle.cabal"])
+# REGENDATA ("0.19.20250801",["github","haggle.cabal"])
 #
 name: Haskell-CI
 on:
@@ -19,7 +19,7 @@ on:
 jobs:
   linux:
     name: Haskell-CI - Linux - ${{ matrix.compiler }}
-    runs-on: ubuntu-20.04
+    runs-on: ubuntu-24.04
     timeout-minutes:
       60
     container:
@@ -90,15 +90,29 @@ jobs:
             allow-failure: false
       fail-fast: false
     steps:
-      - name: apt
+      - name: apt-get install
         run: |
           apt-get update
           apt-get install -y --no-install-recommends gnupg ca-certificates dirmngr curl git software-properties-common libtinfo5 libnuma-dev
+      - name: Install GHCup
+        run: |
           mkdir -p "$HOME/.ghcup/bin"
-          curl -sL https://downloads.haskell.org/ghcup/0.1.30.0/x86_64-linux-ghcup-0.1.30.0 > "$HOME/.ghcup/bin/ghcup"
+          curl -sL https://downloads.haskell.org/ghcup/0.1.50.1/x86_64-linux-ghcup-0.1.50.1 > "$HOME/.ghcup/bin/ghcup"
           chmod a+x "$HOME/.ghcup/bin/ghcup"
+      - name: Install cabal-install
+        run: |
+          "$HOME/.ghcup/bin/ghcup" install cabal 3.16.0.0 || (cat "$HOME"/.ghcup/logs/*.* && false)
+          echo "CABAL=$HOME/.ghcup/bin/cabal-3.16.0.0 -vnormal+nowrap" >> "$GITHUB_ENV"
+      - name: Install GHC (GHCup)
+        if: matrix.setup-method == 'ghcup'
+        run: |
           "$HOME/.ghcup/bin/ghcup" install ghc "$HCVER" || (cat "$HOME"/.ghcup/logs/*.* && false)
-          "$HOME/.ghcup/bin/ghcup" install cabal 3.12.1.0 || (cat "$HOME"/.ghcup/logs/*.* && false)
+          HC=$("$HOME/.ghcup/bin/ghcup" whereis ghc "$HCVER")
+          HCPKG=$(echo "$HC" | sed 's#ghc$#ghc-pkg#')
+          HADDOCK=$(echo "$HC" | sed 's#ghc$#haddock#')
+          echo "HC=$HC" >> "$GITHUB_ENV"
+          echo "HCPKG=$HCPKG" >> "$GITHUB_ENV"
+          echo "HADDOCK=$HADDOCK" >> "$GITHUB_ENV"
         env:
           HCKIND: ${{ matrix.compilerKind }}
           HCNAME: ${{ matrix.compiler }}
@@ -109,21 +123,12 @@ jobs:
           echo "LANG=C.UTF-8" >> "$GITHUB_ENV"
           echo "CABAL_DIR=$HOME/.cabal" >> "$GITHUB_ENV"
           echo "CABAL_CONFIG=$HOME/.cabal/config" >> "$GITHUB_ENV"
-          HCDIR=/opt/$HCKIND/$HCVER
-          HC=$("$HOME/.ghcup/bin/ghcup" whereis ghc "$HCVER")
-          HCPKG=$(echo "$HC" | sed 's#ghc$#ghc-pkg#')
-          HADDOCK=$(echo "$HC" | sed 's#ghc$#haddock#')
-          echo "HC=$HC" >> "$GITHUB_ENV"
-          echo "HCPKG=$HCPKG" >> "$GITHUB_ENV"
-          echo "HADDOCK=$HADDOCK" >> "$GITHUB_ENV"
-          echo "CABAL=$HOME/.ghcup/bin/cabal-3.12.1.0 -vnormal+nowrap" >> "$GITHUB_ENV"
           HCNUMVER=$(${HC} --numeric-version|perl -ne '/^(\d+)\.(\d+)\.(\d+)(\.(\d+))?$/; print(10000 * $1 + 100 * $2 + ($3 == 0 ? $5 != 1 : $3))')
           echo "HCNUMVER=$HCNUMVER" >> "$GITHUB_ENV"
           echo "ARG_TESTS=--enable-tests" >> "$GITHUB_ENV"
           echo "ARG_BENCH=--enable-benchmarks" >> "$GITHUB_ENV"
           echo "HEADHACKAGE=false" >> "$GITHUB_ENV"
           echo "ARG_COMPILER=--$HCKIND --with-compiler=$HC" >> "$GITHUB_ENV"
-          echo "GHCJSARITH=0" >> "$GITHUB_ENV"
         env:
           HCKIND: ${{ matrix.compilerKind }}
           HCNAME: ${{ matrix.compiler }}
@@ -198,7 +203,11 @@ jobs:
           touch cabal.project.local
           echo "packages: ${PKGDIR_haggle}" >> cabal.project
           if [ $((HCNUMVER >= 80200)) -ne 0 ] ; then echo "package haggle" >> cabal.project ; fi
-          if [ $((HCNUMVER >= 80200)) -ne 0 ] ; then echo "    ghc-options: -Werror=missing-methods" >> cabal.project ; fi
+          if [ $((HCNUMVER >= 80200)) -ne 0 ] ; then echo "    ghc-options: -Werror=missing-methods -Werror=missing-fields" >> cabal.project ; fi
+          if [ $((HCNUMVER >= 90400)) -ne 0 ] ; then echo "package haggle" >> cabal.project ; fi
+          if [ $((HCNUMVER >= 90400)) -ne 0 ] ; then echo "    ghc-options: -Werror=unused-packages" >> cabal.project ; fi
+          if [ $((HCNUMVER >= 90000)) -ne 0 ] ; then echo "package haggle" >> cabal.project ; fi
+          if [ $((HCNUMVER >= 90000)) -ne 0 ] ; then echo "    ghc-options: -Werror=incomplete-patterns -Werror=incomplete-uni-patterns" >> cabal.project ; fi
           cat >> cabal.project <<EOF
           EOF
           $HCPKG list --simple-output --names-only | perl -ne 'for (split /\s+/) { print "constraints: any.$_ installed\n" unless /^(haggle)$/; }' >> cabal.project.local
@@ -239,8 +248,8 @@ jobs:
           rm -f cabal.project.local
           $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks all
       - name: save cache
-        uses: actions/cache/save@v4
         if: always()
+        uses: actions/cache/save@v4
         with:
           key: ${{ runner.os }}-${{ matrix.compiler }}-${{ github.sha }}
           path: ~/.cabal/store
diff --git a/ChangeLog.md b/ChangeLog.md
@@ -1,3 +1,10 @@
+0.3.1 (2025-08-13)
+------------------
+
+- Update bounds for compatibility with ghc-9.10
+- Add `hasCycle` for detecting cycles in graphs (@kquick)
+- Optimize DFS algorithms by removing an unnecessary traversal (@kquick)
+
 0.3 (2023-08-20)
 ----------------
 
diff --git a/bench/HaggleBench.hs b/bench/HaggleBench.hs
@@ -1,6 +1,7 @@
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE TupleSections #-}
 {-# LANGUAGE TypeFamilies #-}
+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
 
 module Main ( main ) where
 
diff --git a/haggle.cabal b/haggle.cabal
@@ -1,5 +1,5 @@
 name: haggle
-version: 0.3
+version: 0.3.1
 synopsis: A graph library offering mutable, immutable, and inductive graphs
 description: This library provides mutable (in ST or IO), immutable, and inductive graphs.
              There are multiple graphs implementations provided to support different use
diff --git a/src/Data/Graph/Haggle/Algorithms/Dominators.hs b/src/Data/Graph/Haggle/Algorithms/Dominators.hs
@@ -51,7 +51,9 @@ type Preds = Vector [Int]
 immediateDominators :: (Graph g) => g -> Vertex -> [(Vertex, Vertex)]
 immediateDominators g root = fromMaybe [] $ do
   (res, toNode, _) <- domWork g root
-  return $ tail $ V.toList $ V.imap (\i n -> (toNode!i, toNode!n)) res
+  case V.toList $ V.imap (\i n -> (toNode!i, toNode!n)) res of
+    [] -> error "Impossible: a vertex always dominates itself"
+    _ : rest -> return rest
 
 -- | Compute all of the dominators for each 'Vertex' reachable from the @root@.
 -- Each reachable 'Vertex' is paired with the list of nodes that dominate it,
@@ -66,38 +68,43 @@ dominators g root = fromMaybe [] $ do
            [(n, verts) | n <- rest]
 
 domWork :: (Graph g) => g -> Vertex -> Maybe (IDom, ToNode, FromNode)
-domWork g root
-  | null trees = Nothing
-  | otherwise = return (idom, toNode, fromNode)
+domWork g root =
+  -- Build up a depth-first tree from the root as a first approximation
+  case dff g [root] of
+    [] -> Nothing
+    [tree] ->
+      let (s, ntree) = numberTree 0 tree
+          -- Start with an approximation (idom0) where the idom of each node is
+          -- its parent in the depth-first tree.  Note that index 0 is the root,
+          -- which we will basically be ignoring (since it has no dominator).
+          dom0Map = M.fromList (treeEdges (-1) ntree)
+          idom0 = V.generate (M.size dom0Map) (dom0Map M.!)
+          -- Build a mapping from graph vertices to internal indices.  @treeNodes@
+          -- are nodes that are in the depth-first tree from the root.  @otherNodes@
+          -- are the rest of the nodes in the graph, mapped to -1 (since they aren't
+          -- going to be in the result)
+          treeNodes = M.fromList $ zip (T.flatten tree) (T.flatten ntree)
+          otherNodes = M.fromList $ zip vlist (repeat (-1))
+          fromNode = M.unionWith const treeNodes otherNodes
+
+          -- Translate from internal nodes back to graph nodes (only need the nodes
+          -- in the depth-first tree)
+          toNodeMap = M.fromList $ zip (T.flatten ntree) (T.flatten tree)
+          toNode = V.generate (M.size toNodeMap) (toNodeMap M.!)
+
+          -- Use a pre-pass over the graph to collect predecessors so that we don't
+          -- require a Bidirectional graph.  We need a linear pass over the graph
+          -- here anyway, so we don't lose anything.
+          predMap = fmap S.toList $ foldr (toPredecessor g) M.empty vlist
+          preds = V.fromList $ [0] : [filter (/= -1) (map (fromNode M.!) (predMap M.! (toNode ! i)))
+                                     | i <- [1..s-1]]
+
+
+          idom = fixEq (refineIDom preds) idom0
+      in return (idom, toNode, fromNode)
+    _trees -> error "Impossible: only a single tree can be reachable starting from a single root node"
   where
     vlist = reachable root g
-    -- Build up a depth-first tree from the root as a first approximation
-    trees@(~[tree]) = dff g [root]
-    (s, ntree) = numberTree 0 tree
-    -- Start with an approximation (idom0) where the idom of each node is
-    -- its parent in the depth-first tree.  Note that index 0 is the root,
-    -- which we will basically be ignoring (since it has no dominator).
-    dom0Map = M.fromList (treeEdges (-1) ntree)
-    idom0 = V.generate (M.size dom0Map) (dom0Map M.!)
-    -- Build a mapping from graph vertices to internal indices.  @treeNodes@
-    -- are nodes that are in the depth-first tree from the root.  @otherNodes@
-    -- are the rest of the nodes in the graph, mapped to -1 (since they aren't
-    -- going to be in the result)
-    treeNodes = M.fromList $ zip (T.flatten tree) (T.flatten ntree)
-    otherNodes = M.fromList $ zip vlist (repeat (-1))
-    fromNode = M.unionWith const treeNodes otherNodes
-    -- Translate from internal nodes back to graph nodes (only need the nodes
-    -- in the depth-first tree)
-    toNodeMap = M.fromList $ zip (T.flatten ntree) (T.flatten tree)
-    toNode = V.generate (M.size toNodeMap) (toNodeMap M.!)
-
-    -- Use a pre-pass over the graph to collect predecessors so that we don't
-    -- require a Bidirectional graph.  We need a linear pass over the graph
-    -- here anyway, so we don't lose anything.
-    predMap = fmap S.toList $ foldr (toPredecessor g) M.empty vlist
-    preds = V.fromList $ [0] : [filter (/= -1) (map (fromNode M.!) (predMap M.! (toNode ! i)))
-                               | i <- [1..s-1]]
-    idom = fixEq (refineIDom preds) idom0
 
 toPredecessor :: (Graph g)
               => g
diff --git a/src/Data/Graph/Haggle/Classes.hs b/src/Data/Graph/Haggle/Classes.hs
@@ -219,6 +219,7 @@ class (Graph g, HasEdgeLabel g, HasVertexLabel g) => InductiveGraph g where
     return g'
 
 addEdgeLabel :: (HasEdgeLabel g) => g -> Edge -> (Edge, EdgeLabel g)
-addEdgeLabel g e = (e, el)
-  where
-   Just el = edgeLabel g e
+addEdgeLabel g e =
+  case edgeLabel g e of
+    Just el -> (e, el)
+    Nothing -> error "Expected an edge label for a graph implementation satisfying the HasEdgeLabel constraint"
diff --git a/src/Data/Graph/Haggle/Internal/Adapter.hs b/src/Data/Graph/Haggle/Internal/Adapter.hs
@@ -324,17 +324,19 @@ labeledVertices :: (I.Graph g) => LabeledGraph g nl el -> [(I.Vertex, nl)]
 labeledVertices g = map toLabVert $ I.vertices (rawGraph g)
   where
     toLabVert v =
-      let Just lab = vertexLabel g v
-      in (v, lab)
+      case vertexLabel g v of
+        Just lab -> (v, lab)
+        Nothing -> error "Impossible: LabeledGraphs always have vertex labels"
 
 -- | Likewise, we use 'edges' here instead of directly reading from the edge
 -- label storage array.
 labeledEdges :: (I.Graph g) => LabeledGraph g nl el -> [(I.Edge, el)]
 labeledEdges g = map toLabEdge $ I.edges (rawGraph g)
   where
     toLabEdge e =
-      let Just lab = edgeLabel g e
-      in (e, lab)
+      case edgeLabel g e of
+        Just lab -> (e, lab)
+        Nothing -> error "Impossible: LabeledGraphs always have edge labels"
 
 mapEdgeLabel :: LabeledGraph g nl el -> (el -> el') -> LabeledGraph g nl el'
 mapEdgeLabel g f = g { edgeLabelStore = V.map f (edgeLabelStore g) }
diff --git a/src/Data/Graph/Haggle/PatriciaTree.hs b/src/Data/Graph/Haggle/PatriciaTree.hs
@@ -79,8 +79,10 @@ instance I.HasEdgeLabel (PatriciaTree nl el) where
   labeledEdges gr = map toLabEdge (I.edges gr)
     where
       toLabEdge e =
-        let Just lab = I.edgeLabel gr e
-        in (e, lab)
+        case I.edgeLabel gr e of
+          Just lab -> (e, lab)
+          Nothing -> error "Impossible: PatriciaTree instances always have edge labels"
+
   labeledOutEdges (Gr g) (I.V s) = fromMaybe [] $ do
     Ctx _ _ _ ss <- IM.lookup s g
     return $ IM.foldrWithKey toOut [] ss
@@ -95,8 +97,9 @@ instance I.HasVertexLabel (PatriciaTree nl el) where
   labeledVertices gr = map toLabVert (I.vertices gr)
     where
       toLabVert v =
-        let Just l = I.vertexLabel gr v
-        in (v, l)
+        case I.vertexLabel gr v of
+          Just l -> (v, l)
+          Nothing -> error "Impossible: PatriciaTree instances always have vertex labels"
 
 instance I.Bidirectional (PatriciaTree nl el) where
   predecessors (Gr g) (I.V v) = fromMaybe [] $ do
diff --git a/tests/GraphTests.hs b/tests/GraphTests.hs
@@ -2,8 +2,10 @@
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
 {-# LANGUAGE UndecidableInstances #-}
 {-# OPTIONS_GHC -fno-warn-missing-signatures #-}
+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
 
 -- | This module tests Haggle by comparing its results to those of FGL.
 -- This assumes that FGL is reasonably correct.
@@ -25,8 +27,6 @@ import Control.Arrow ( first, second )
 import qualified Data.Bifunctor as Bi
 import Control.Monad ( replicateM )
 import Data.Function ( on )
-import Control.Monad.ST
-import Control.Monad ( liftM, filterM, replicateM )
 import qualified Data.Foldable as F
 import qualified Data.List as L
 import Data.Maybe ( fromJust, isNothing )
