From b1a771e660db85e1fd2dcb188eec47728069429b Mon Sep 17 00:00:00 2001
From: Karl Ostmo <kostmo@gmail.com>
Date: Mon, 17 Jul 2023 22:15:31 -0700
Subject: [PATCH] generic sequenceA operation for tuples without Monoid
 requirement

---
 .../Scenario/Topography/Navigation/Portal.hs    | 11 ++---------
 src/Swarm/Util.hs                               | 17 +++++++++++++++++
 2 files changed, 19 insertions(+), 9 deletions(-)

diff --git a/src/Swarm/Game/Scenario/Topography/Navigation/Portal.hs b/src/Swarm/Game/Scenario/Topography/Navigation/Portal.hs
index 768b4beb80..f2385149f8 100644
--- a/src/Swarm/Game/Scenario/Topography/Navigation/Portal.hs
+++ b/src/Swarm/Game/Scenario/Topography/Navigation/Portal.hs
@@ -26,7 +26,7 @@ import Linear (negated)
 import Swarm.Game.Location
 import Swarm.Game.Scenario.Topography.Navigation.Waypoint
 import Swarm.Game.Universe
-import Swarm.Util (allEqual, binTuples, both, quote)
+import Swarm.Util (allEqual, binTuples, both, quote, sequenceTuple)
 
 type WaypointMap = M.Map WaypointName (NonEmpty Location)
 
@@ -244,18 +244,11 @@ ensureSpatialConsistency xs =
 
   tuplify = both (view subworld) &&& both (view planar)
 
-  nest ::
-    Signed (b, a) ->
-    (b, Signed a)
-  nest = \case
-    Positive x -> fmap Positive x
-    Negative x -> fmap Negative x
-
   reExtract = \case
     Positive x -> x
     Negative x -> negated x
 
-  groupedBySubworldPair = binTuples $ map (nest . fmap tuplify) normalizedOrdering
+  groupedBySubworldPair = binTuples $ map (sequenceTuple . fmap tuplify) normalizedOrdering
   vectorized = M.map (NE.map (reExtract . fmap (uncurry (.-.)))) groupedBySubworldPair
 
   nonUniform = M.filter ((not . allEqual) . NE.toList) vectorized
diff --git a/src/Swarm/Util.hs b/src/Swarm/Util.hs
index 114d122ccc..bf1d0fdd93 100644
--- a/src/Swarm/Util.hs
+++ b/src/Swarm/Util.hs
@@ -22,6 +22,7 @@ module Swarm.Util (
   findDup,
   both,
   allEqual,
+  sequenceTuple,
 
   -- * Directory utilities
   readFileMay,
@@ -193,6 +194,22 @@ both f = bimap f f
 allEqual :: (Ord a) => [a] -> Bool
 allEqual = (== 1) . S.size . S.fromList
 
+-- | This function has a lamentable basis.
+-- The 'sequenceA' function requires an 'Applicative' instance
+-- for the inner functor. However, the 'Applictaive' instance
+-- of @(,)@ (the two-element tuple) requires a 'Monoid' instance
+-- for the first element!
+-- See: https://hackage.haskell.org/package/base-4.18.0.0/docs/src/GHC.Base.html#line-523
+--
+-- The 'sequenceA' operation does not affect the first element
+-- of the tuple, so it shouldn't matter whether it has a 'Monoid' instance!
+-- To satisfy the compiler, we abuse a list to wrap and then unwrap after a traversal.
+sequenceTuple ::
+  Traversable f =>
+  f (a, b) ->
+  (a, f b)
+sequenceTuple = first head . traverse (first pure)
+
 ------------------------------------------------------------
 -- Directory stuff