From 3d5abaa71a325a19d97bc47075227fc940d8db1d Mon Sep 17 00:00:00 2001
From: David Feuer <David.Feuer@gmail.com>
Date: Mon, 23 Apr 2018 21:36:29 -0400
Subject: [PATCH 1/2] Fancy rules for traversing with PrimMonad

---
 Data/Primitive/Array.hs | 42 ++++++++++++++++++++++++++++++-----------
 1 file changed, 31 insertions(+), 11 deletions(-)

diff --git a/Data/Primitive/Array.hs b/Data/Primitive/Array.hs
index fc0301c9..c4fe75f1 100644
--- a/Data/Primitive/Array.hs
+++ b/Data/Primitive/Array.hs
@@ -1,6 +1,7 @@
 {-# LANGUAGE CPP, MagicHash, UnboxedTuples, DeriveDataTypeable, BangPatterns #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE GADTs, ConstraintKinds #-}
 
 -- |
 -- Module      : Data.Primitive.Array
@@ -73,6 +74,9 @@ import Text.ParserCombinators.ReadP
 #if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,4,0)
 import Data.Functor.Classes (Eq1(..),Ord1(..),Show1(..),Read1(..))
 #endif
+import Control.Monad.Trans.Maybe
+import Control.Monad.Trans.Identity
+import Control.Monad.Trans.State.Strict
 
 -- | Boxed arrays
 data Array a = Array
@@ -520,18 +524,34 @@ traverseArray f = \ !ary ->
 {-# INLINE [1] traverseArray #-}
 
 {-# RULES
-"traverse/ST" forall (f :: a -> ST s b). traverseArray f =
-   traverseArrayP f
-"traverse/IO" forall (f :: a -> IO b). traverseArray f =
-   traverseArrayP f
+"toWonk" [~1] traverseArray
+  = traverseArrayWonk (WonkP (\(Dict :: Dict (PrimMonad f)) (g :: a -> f b) -> traverseArrayP g))
+"wonkIO" forall (w :: WonkP IO f).
+  traverseArrayWonk w = runWonkP w Dict
+"wonkST" forall (w :: WonkP (ST s) f).
+  traverseArrayWonk w = runWonkP w Dict
+"wonkMaybeT" forall (w :: WonkP (MaybeT m) f).
+  traverseArrayWonk w = traverseArrayWonk (WonkP (\(Dict :: Dict (PrimMonad m)) -> runWonkP w Dict))
+"wonkStateT" forall (w :: WonkP (StateT s m) f).
+  traverseArrayWonk w = traverseArrayWonk (WonkP (\(Dict :: Dict (PrimMonad m)) -> runWonkP w Dict))
+"wonkIdentityT" forall (w :: WonkP (IdentityT m) f).
+  traverseArrayWonk w = traverseArrayWonk (WonkP (\(Dict :: Dict (PrimMonad m)) -> runWonkP w Dict))
  #-}
-#if MIN_VERSION_base(4,8,0)
-{-# RULES
-"traverse/Id" forall (f :: a -> Identity b). traverseArray f =
-   (coerce :: (Array a -> Array (Identity b))
-           -> Array a -> Identity (Array b)) (fmap f)
- #-}
-#endif
+
+data Dict c where
+  Dict :: c => Dict c
+
+newtype WonkP m f = WonkP
+  { runWonkP :: forall a b. Dict (PrimMonad m) -> (a -> f b) -> Array a -> f (Array b) }
+
+traverseArrayWonk
+  :: Applicative f
+  => WonkP m f
+  -> (a -> f b)
+  -> Array a
+  -> f (Array b)
+traverseArrayWonk _ f = traverseArray f
+{-# INLINE [0] traverseArrayWonk #-}
 
 -- | This is the fastest, most straightforward way to traverse
 -- an array, but it only works correctly with a sufficiently

From 7f38887b891cdfd67f33f057cd18902cd256db31 Mon Sep 17 00:00:00 2001
From: David Feuer <David.Feuer@gmail.com>
Date: Mon, 23 Apr 2018 21:56:04 -0400
Subject: [PATCH 2/2] Simplify; remove some extensions

---
 Data/Primitive/Array.hs | 25 +++++++++++--------------
 1 file changed, 11 insertions(+), 14 deletions(-)

diff --git a/Data/Primitive/Array.hs b/Data/Primitive/Array.hs
index c4fe75f1..bf7664a3 100644
--- a/Data/Primitive/Array.hs
+++ b/Data/Primitive/Array.hs
@@ -1,7 +1,6 @@
 {-# LANGUAGE CPP, MagicHash, UnboxedTuples, DeriveDataTypeable, BangPatterns #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE GADTs, ConstraintKinds #-}
 
 -- |
 -- Module      : Data.Primitive.Array
@@ -523,27 +522,25 @@ traverseArray f = \ !ary ->
      else runSTA len <$> go 0
 {-# INLINE [1] traverseArray #-}
 
+newtype WonkP m f = WonkP
+  { runWonkP :: forall a b. PrimMonad m => (a -> f b) -> Array a -> f (Array b) }
+
 {-# RULES
-"toWonk" [~1] traverseArray
-  = traverseArrayWonk (WonkP (\(Dict :: Dict (PrimMonad f)) (g :: a -> f b) -> traverseArrayP g))
+"toWonk" [~1] traverseArray = traverseArrayWonk (WonkP traverseArrayP :: WonkP f f)
+
 "wonkIO" forall (w :: WonkP IO f).
-  traverseArrayWonk w = runWonkP w Dict
+  traverseArrayWonk w = runWonkP w
 "wonkST" forall (w :: WonkP (ST s) f).
-  traverseArrayWonk w = runWonkP w Dict
+  traverseArrayWonk w = runWonkP w
+
 "wonkMaybeT" forall (w :: WonkP (MaybeT m) f).
-  traverseArrayWonk w = traverseArrayWonk (WonkP (\(Dict :: Dict (PrimMonad m)) -> runWonkP w Dict))
+  traverseArrayWonk w = traverseArrayWonk (WonkP (runWonkP w) :: WonkP m f)
 "wonkStateT" forall (w :: WonkP (StateT s m) f).
-  traverseArrayWonk w = traverseArrayWonk (WonkP (\(Dict :: Dict (PrimMonad m)) -> runWonkP w Dict))
+  traverseArrayWonk w = traverseArrayWonk (WonkP (runWonkP w) :: WonkP m f)
 "wonkIdentityT" forall (w :: WonkP (IdentityT m) f).
-  traverseArrayWonk w = traverseArrayWonk (WonkP (\(Dict :: Dict (PrimMonad m)) -> runWonkP w Dict))
+  traverseArrayWonk w = traverseArrayWonk (WonkP (runWonkP w) :: WonkP m f)
  #-}
 
-data Dict c where
-  Dict :: c => Dict c
-
-newtype WonkP m f = WonkP
-  { runWonkP :: forall a b. Dict (PrimMonad m) -> (a -> f b) -> Array a -> f (Array b) }
-
 traverseArrayWonk
   :: Applicative f
   => WonkP m f