From 659c7a066d9637b47f8d73f8b10a7c32cbf02093 Mon Sep 17 00:00:00 2001
From: Karl Ostmo <kostmo@gmail.com>
Date: Wed, 19 Jul 2023 14:07:30 -0700
Subject: [PATCH] address sequenceTuple issue

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

diff --git a/src/Swarm/Game/Scenario/Topography/Navigation/Portal.hs b/src/Swarm/Game/Scenario/Topography/Navigation/Portal.hs
index 13b7d1a43..d74e08536 100644
--- a/src/Swarm/Game/Scenario/Topography/Navigation/Portal.hs
+++ b/src/Swarm/Game/Scenario/Topography/Navigation/Portal.hs
@@ -27,7 +27,7 @@ import Linear (V2, negated)
 import Swarm.Game.Location
 import Swarm.Game.Scenario.Topography.Navigation.Waypoint
 import Swarm.Game.Universe
-import Swarm.Util (allEqual, binTuples, both, failT, quote, sequenceTuple)
+import Swarm.Util (allEqual, binTuples, both, failT, quote)
 
 type WaypointMap = M.Map WaypointName (NonEmpty Location)
 
@@ -249,10 +249,44 @@ ensureSpatialConsistency xs =
 
   groupedBySubworldPair ::
     Map (SubworldName, SubworldName) (NonEmpty (Signed (Location, Location)))
-  groupedBySubworldPair = binTuples $ map (sequenceTuple . fmap tuplify) normalizedOrdering
+  groupedBySubworldPair = binTuples $ map (sequenceSigned . fmap tuplify) normalizedOrdering
 
   vectorized :: Map (SubworldName, SubworldName) (NonEmpty (V2 Int32))
   vectorized = M.map (NE.map (getSigned . fmap (uncurry (.-.)))) groupedBySubworldPair
 
   nonUniform :: Map (SubworldName, SubworldName) (NonEmpty (V2 Int32))
   nonUniform = M.filter ((not . allEqual) . NE.toList) vectorized
+
+-- |
+-- An implementation of 'sequenceA' for 'Signed' that does not
+-- require an 'Applicative' instance for the inner 'Functor'.
+--
+-- == Discussion
+-- Compare to the 'Traversable' instance of 'Signed':
+-- @
+-- instance Traversable Signed where
+--   traverse f (Positive x) = Positive <$> f x
+--   traverse f (Negative x) = Negative <$> f x
+-- @
+--
+-- if we were to substitute 'id' for f:
+-- @
+--   traverse id (Positive x) = Positive <$> id x
+--   traverse id (Negative x) = Negative <$> id x
+-- @
+-- our implementation essentially becomes @traverse id@.
+--
+-- However, we cannot simply write our implementation as @traverse id@, because
+-- the 'traverse' function has an 'Applicative' constraint, which is superfluous
+-- for our purpose.
+--
+-- Perhaps there is an opportunity to invent a typeclass for datatypes which
+-- consist exclusively of unary (or more ambitiously, non-nullary?) data constructors,
+-- for which a less-constrained 'sequence' function could be automatically derived.
+sequenceSigned ::
+  Functor f =>
+  Signed (f a) ->
+  f (Signed a)
+sequenceSigned = \case
+  Positive x -> Positive <$> x
+  Negative x -> Negative <$> x
diff --git a/src/Swarm/Util.hs b/src/Swarm/Util.hs
index 1dc3038c6..e71a8af8d 100644
--- a/src/Swarm/Util.hs
+++ b/src/Swarm/Util.hs
@@ -22,7 +22,6 @@ module Swarm.Util (
   findDup,
   both,
   allEqual,
-  sequenceTuple,
 
   -- * Directory utilities
   readFileMay,
@@ -195,22 +194,6 @@ allEqual :: (Ord a) => [a] -> Bool
 allEqual [] = True
 allEqual (x : xs) = all (== x) xs
 
--- | This function has a lamentable basis.
--- The 'sequenceA' function requires an 'Applicative' instance
--- for the inner 'Functor'. However, the 'Applicative' 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 first wrap and then unwrap after a traversal.
-sequenceTuple ::
-  Traversable f =>
-  f (a, b) ->
-  (a, f b)
-sequenceTuple = first head . traverse (first pure)
-
 ------------------------------------------------------------
 -- Directory stuff