From e179aded1fb8dc40608ad99168e2bff58a6ab961 Mon Sep 17 00:00:00 2001
From: Jason Dagit <dagitj@gmail.com>
Date: Sun, 25 Jul 2021 20:42:53 -0700
Subject: [PATCH 1/8] It's slow but it technically it's stream fusion

---
 src/Control/Monad/Logic/Sequence/Internal.hs | 140 +++++++++++++++----
 1 file changed, 114 insertions(+), 26 deletions(-)

diff --git a/src/Control/Monad/Logic/Sequence/Internal.hs b/src/Control/Monad/Logic/Sequence/Internal.hs
index a6d75ef..f516b6e 100644
--- a/src/Control/Monad/Logic/Sequence/Internal.hs
+++ b/src/Control/Monad/Logic/Sequence/Internal.hs
@@ -17,7 +17,7 @@
 #endif
 
 #if __GLASGOW_HASKELL__ >= 704
-{-# LANGUAGE Safe #-}
+{-# LANGUAGE Trustworthy #-}
 #endif
 {-# OPTIONS_HADDOCK not-home #-}
 
@@ -133,7 +133,7 @@ instance (Show1 m, Monad m) => Show1 (View m) where
 -- it's really defined this way! However, the real implementation is different,
 -- so as to be more efficient in the face of deeply left-associated `<|>` or
 -- `mplus` applications.
-newtype SeqT m a = SeqT (Queue (m (View m a)))
+newtype SeqT m a = SeqT { runSeqT :: (Queue (m (View m a))) }
 
 #ifdef USE_PATTERN_SYNONYMS
 pattern MkSeqT :: Monad m => m (View m a) -> SeqT m a
@@ -164,7 +164,7 @@ type Seq = SeqT Identity
 
 fromView :: m (View m a) -> SeqT m a
 fromView = SeqT . S.singleton
-{-# INLINE fromView #-}
+{-# INLINE[0] fromView #-}
 
 toView :: Monad m => SeqT m a -> m (View m a)
 toView (SeqT s) = case S.viewl s of
@@ -172,8 +172,65 @@ toView (SeqT s) = case S.viewl s of
   h S.:< t -> h >>= \x -> case x of
     Empty -> toView (SeqT t)
     hi :< SeqT ti -> return (hi :< SeqT (ti S.>< t))
-{-# INLINEABLE toView #-}
-{-# SPECIALIZE INLINE toView :: Seq a -> Identity (View Identity a) #-}
+{-# INLINEABLE[0] toView #-}
+
+data Step s a = Done | Yield a s
+-- data Stream a = forall s. Stream (s -> Step s a) s
+data StreamM m a = forall s. StreamM (s -> m (Step s a)) s
+
+-- type ViewS m a = Stream (m (View m a))
+
+stream :: Monad m => SeqT m a -> StreamM m a
+stream m = StreamM next m where
+  {-# INLINE next #-}
+  next s = step <$> toView s
+  step Empty = Done
+  step (h :< t) = Yield h t
+{-# INLINE[1] stream #-}
+
+unstream :: forall m a. Monad m => StreamM m a -> SeqT m a
+unstream (StreamM next (s0::s)) = SeqT (unfold s0)
+  where
+  unfold :: s -> Queue (m (View m a))
+  unfold s = S.singleton (step <$> next s)
+  step Done = Empty
+  step (Yield x xs) = x :< SeqT (unfold xs)
+{-# INLINE[1] unstream #-}
+
+{-# RULES
+      "stream-unstream" [2] forall s. stream (unstream s) = s;
+      "toView-fromView" [1] forall s. fromView (toView s) = s;
+  #-}
+
+newtype Fix1 f a = In1 { out1 :: f (Fix1 f a) a }
+
+chooseStreamM :: (Foldable f, Monad m) => f a -> StreamM m a
+chooseStreamM = StreamM (return . out1) . foldr (\a b -> In1 (Yield a b)) (In1 Done)
+{-# INLINEABLE[1] chooseStreamM #-}
+
+chooseSeqT :: (Foldable f, Monad m) => f a -> SeqT m a
+chooseSeqT = unstream . chooseStreamM
+{-# INLINEABLE[3] chooseSeqT #-}
+
+{-
+chooseSeqT :: (Foldable t, Monad m) => t a -> SeqT m a
+chooseSeqT xs = unstream (foldr (alt_s . stream . pure) done xs)
+{-# INLINEABLE [3] chooseSeqT #-}
+
+chooseSeqTList :: Monad m => [a] -> SeqT m a
+chooseSeqTList xs = unstream (StreamM next xs)
+  where
+  next [] = return Done
+  next (y:ys) = return (Yield y ys)
+{-# INLINEABLE [3] chooseSeqTList #-}
+
+{-# RULES
+    "chooseSeqT list" [4] chooseSeqT = chooseSeqTList;
+  #-}
+-}
+asumSeqT :: (Monad m, Foldable t) => t (SeqT m a) -> SeqT m a
+asumSeqT = unstream . foldr (alt_s . stream) done
+{-# INLINE [3] asumSeqT #-}
 
 {-
 Theorem: toView . fromView = id
@@ -234,7 +291,6 @@ instance (Show1 m, Monad m) => Show1 (SeqT m) where
 single :: Monad m => a -> m (View m a)
 single a = return (a :< mzero)
 {-# INLINE single #-}
-{-# SPECIALIZE INLINE single :: a -> Identity (View Identity a) #-}
 
 instance Monad m => Functor (SeqT m) where
   {-# INLINEABLE fmap #-}
@@ -256,30 +312,64 @@ instance Monad m => Applicative (SeqT m) where
 instance Monad m => Alternative (SeqT m) where
   {-# INLINE empty #-}
   {-# INLINEABLE (<|>) #-}
-  {-# SPECIALIZE INLINE (<|>) :: Seq a -> Seq a -> Seq a #-}
   empty = SeqT S.empty
-  m <|> n = fromView (altView m n)
+  (<|>) = alt
+
+alt :: Monad m => SeqT m a -> SeqT m a -> SeqT m a
+alt a b = unstream (alt_s (stream a) (stream b))
+{-# INLINE[3] alt #-}
 
-altView :: Monad m => SeqT m a -> SeqT m a -> m (View m a)
-altView (toView -> m) n = m >>= \x -> case x of
-  Empty -> toView n
-  h :< t -> return (h :< cat t n)
-    where cat (SeqT l) (SeqT r) = SeqT (l S.>< r)
-{-# INLINE altView #-}
+alt_s :: Monad m => StreamM m a -> StreamM m a -> StreamM m a
+alt_s (StreamM next_a a) (StreamM next_b b) = StreamM next (Just a, b)
+  where
+  {-# INLINE next #-}
+  next (Nothing, s_b) = do
+    x <- next_b s_b
+    return $ case x of
+      Done -> Done
+      Yield v vs -> Yield v (Nothing, vs)
+  next (Just s_a, s_b) = do
+    y <- next_a s_a
+    case y of
+      Done -> do
+        x <- next_b s_b
+        return $ case x of
+          Done -> Done
+          Yield v vs -> Yield v (Nothing, vs)
+      Yield x xs -> return (Yield x (Just xs, s_b))
+{-# INLINE[1] alt_s #-}
 
 instance Monad m => Monad (SeqT m) where
   {-# INLINE return #-}
   {-# INLINEABLE (>>=) #-}
-  {-# SPECIALIZE INLINE (>>=) :: Seq a -> (a -> Seq b) -> Seq b #-}
   return = fromView . single
-  (toView -> m) >>= f = fromView $ m >>= \x -> case x of
-    Empty -> return Empty
-    h :< t -> f h `altView` (t >>= f)
-
-  {-# INLINEABLE (>>) #-}
-  (toView -> m) >> n = fromView $ m >>= \x -> case x of
-    Empty -> return Empty
-    _ :< t -> n `altView` (t >> n)
+  (>>=) = bind
+
+bind :: Monad m => SeqT m a -> (a -> SeqT m b) -> SeqT m b
+bind m f = unstream (bind_s (stream m) (stream . f))
+{-# INLINE[3] bind #-}
+
+done :: Monad m => StreamM m a
+done = StreamM (const (return Done)) Empty
+{-# INLINE CONLIKE [0] done #-}
+
+data BindSState a b m = Boundary a | forall s. InProgress a (s -> m (Step s b)) s
+
+bind_s :: Monad m => StreamM m a -> (a -> StreamM m b) -> StreamM m b
+bind_s (StreamM next_a a0) f = StreamM next (Boundary a0) where
+  {-# INLINE next #-}
+  next (Boundary s_a) = do
+    x <- next_a s_a
+    case x of
+      Yield a as -> case f a of
+        StreamM next_fa fa0 -> next (InProgress as next_fa fa0)
+      Done -> return Done
+  next (InProgress s_a next_b s_b) = do
+    x <- next_b s_b
+    case x of
+      Yield b bs -> return (Yield b (InProgress s_a next_b bs))
+      Done -> next (Boundary s_a)
+{-# INLINE[1] bind_s #-}
 
 #if !MIN_VERSION_base(4,13,0)
   {-# INLINEABLE fail #-}
@@ -317,8 +407,7 @@ instance MonadTrans SeqT where
   lift m = fromView (m >>= single)
 
 instance Monad m => MonadLogic (SeqT m) where
-  {-# INLINE msplit #-}
-  {-# SPECIALIZE INLINE msplit :: Seq a -> Seq (Maybe (a, Seq a)) #-}
+  {-# INLINE[3] msplit #-}
   msplit (toView -> m) = fromView $ do
     r <- m
     case r of
@@ -330,7 +419,6 @@ observeAllT (toView -> m) = m >>= go where
   go (a :< t) = liftM (a:) (toView t >>= go)
   go _ = return []
 {-# INLINEABLE observeAllT #-}
-{-# SPECIALIZE INLINE observeAllT :: Seq a -> Identity [a] #-}
 
 observeT :: Monad m => SeqT m a -> m (Maybe a)
 observeT (toView -> m) = m >>= go where

From 95cd98dea8414028ef791b7f18b2d11f8a51550f Mon Sep 17 00:00:00 2001
From: Jason Dagit <dagitj@gmail.com>
Date: Sun, 25 Jul 2021 22:50:40 -0700
Subject: [PATCH 2/8] Minor refinements

---
 src/Control/Monad/Logic/Sequence/Internal.hs | 101 ++++++++++++++-----
 1 file changed, 77 insertions(+), 24 deletions(-)

diff --git a/src/Control/Monad/Logic/Sequence/Internal.hs b/src/Control/Monad/Logic/Sequence/Internal.hs
index f516b6e..de8410d 100644
--- a/src/Control/Monad/Logic/Sequence/Internal.hs
+++ b/src/Control/Monad/Logic/Sequence/Internal.hs
@@ -49,6 +49,9 @@ module Control.Monad.Logic.Sequence.Internal
   , hoistPostUnexposed
   , toLogicT
   , fromLogicT
+  , chooseStreamM
+  , chooseSeqT
+  , asumSeqT
 )
 where
 
@@ -167,34 +170,36 @@ fromView = SeqT . S.singleton
 {-# INLINE[0] fromView #-}
 
 toView :: Monad m => SeqT m a -> m (View m a)
-toView (SeqT s) = case S.viewl s of
-  S.EmptyL -> return Empty
-  h S.:< t -> h >>= \x -> case x of
-    Empty -> toView (SeqT t)
-    hi :< SeqT ti -> return (hi :< SeqT (ti S.>< t))
-{-# INLINEABLE[0] toView #-}
-
-data Step s a = Done | Yield a s
--- data Stream a = forall s. Stream (s -> Step s a) s
-data StreamM m a = forall s. StreamM (s -> m (Step s a)) s
+toView (SeqT s0) = go s0 where
+  go s = case S.viewl s of
+    S.EmptyL -> return Empty
+    h S.:< t -> h >>= \x -> case x of
+      Empty -> go t
+      hi :< SeqT ti -> return (hi :< SeqT (ti S.>< t))
+{-# INLINE[0] toView #-}
 
--- type ViewS m a = Stream (m (View m a))
+data Step s a = Done | Yield a s | Skip s
+data StreamM m a = forall s. StreamM (s -> m (Step s a)) s
 
 stream :: Monad m => SeqT m a -> StreamM m a
 stream m = StreamM next m where
   {-# INLINE next #-}
-  next s = step <$> toView s
-  step Empty = Done
-  step (h :< t) = Yield h t
+  next s = do
+    x <- toView s
+    case x of
+      Empty -> return Done
+      h :< t -> return (Yield h t)
 {-# INLINE[1] stream #-}
 
-unstream :: forall m a. Monad m => StreamM m a -> SeqT m a
-unstream (StreamM next (s0::s)) = SeqT (unfold s0)
+unstream :: Monad m => StreamM m a -> SeqT m a
+unstream (StreamM next s0) = fromView (unfold s0)
   where
-  unfold :: s -> Queue (m (View m a))
-  unfold s = S.singleton (step <$> next s)
-  step Done = Empty
-  step (Yield x xs) = x :< SeqT (unfold xs)
+  unfold s = do
+    v <- next s
+    case v of
+      Done -> return Empty
+      Skip xs -> unfold xs
+      Yield x xs -> return (x :< fromView (unfold xs))
 {-# INLINE[1] unstream #-}
 
 {-# RULES
@@ -206,11 +211,11 @@ newtype Fix1 f a = In1 { out1 :: f (Fix1 f a) a }
 
 chooseStreamM :: (Foldable f, Monad m) => f a -> StreamM m a
 chooseStreamM = StreamM (return . out1) . foldr (\a b -> In1 (Yield a b)) (In1 Done)
-{-# INLINEABLE[1] chooseStreamM #-}
+{-# INLINE[1] chooseStreamM #-}
 
 chooseSeqT :: (Foldable f, Monad m) => f a -> SeqT m a
 chooseSeqT = unstream . chooseStreamM
-{-# INLINEABLE[3] chooseSeqT #-}
+{-# INLINE[3] chooseSeqT #-}
 
 {-
 chooseSeqT :: (Foldable t, Monad m) => t a -> SeqT m a
@@ -327,6 +332,7 @@ alt_s (StreamM next_a a) (StreamM next_b b) = StreamM next (Just a, b)
     x <- next_b s_b
     return $ case x of
       Done -> Done
+      Skip vs -> Skip (Nothing, vs)
       Yield v vs -> Yield v (Nothing, vs)
   next (Just s_a, s_b) = do
     y <- next_a s_a
@@ -335,7 +341,9 @@ alt_s (StreamM next_a a) (StreamM next_b b) = StreamM next (Just a, b)
         x <- next_b s_b
         return $ case x of
           Done -> Done
+          Skip vs -> Skip (Nothing, vs)
           Yield v vs -> Yield v (Nothing, vs)
+      Skip vs -> return (Skip (Just vs, s_b))
       Yield x xs -> return (Yield x (Just xs, s_b))
 {-# INLINE[1] alt_s #-}
 
@@ -353,8 +361,50 @@ done :: Monad m => StreamM m a
 done = StreamM (const (return Done)) Empty
 {-# INLINE CONLIKE [0] done #-}
 
-data BindSState a b m = Boundary a | forall s. InProgress a (s -> m (Step s b)) s
+data BindSState a b m
+  = Boundary a
+  | forall s. InProgress a (s -> m (Step s b)) s
+  | forall s. InSkip s
 
+-- I wanted to see how well `bind_s` fuses if `next` is not recursive.
+-- That took a bit of rewriting and the result is quite ugly. It is
+-- slightly faster, so I think that means it does fuse better, but
+-- frankly, it's an awful mess.
+bind_s :: Monad m => StreamM m a -> (a -> StreamM m b) -> StreamM m b
+bind_s (StreamM next_a a0) f = StreamM next (Boundary a0) where
+  {-# INLINE next #-}
+  next (Boundary s_a) = do
+    x <- next_a s_a
+    case x of
+      Yield a as -> case f a of
+        StreamM next_fa fa0 -> do
+          y <- next_fa fa0
+          case y of
+            Yield b bs -> return (Yield b (InProgress as next_fa bs))
+            Skip bs -> return (Skip (InProgress as next_fa bs))
+            Done -> return (Skip (InProgress as next_fa fa0))
+      Skip as -> return (Skip (InSkip as))
+      Done -> return Done
+  next (InProgress s_a next_b s_b) = do
+    x <- next_b s_b
+    case x of
+      Yield b bs -> return (Yield b (InProgress s_a next_b bs))
+      Skip bs -> return (Skip (InProgress s_a next_b bs))
+      Done -> do
+        z <- next_a s_a
+        case z of
+          Yield a as -> case f a of
+            StreamM next_fa fa0 -> do
+              y <- next_fa fa0
+              case y of
+                Yield b bs -> return (Yield b (InProgress as next_fa bs))
+                Skip bs -> return (Skip (InProgress as next_fa bs))
+                Done -> return (Skip (InProgress as next_fa fa0))
+          Skip as -> return (Skip (InSkip as))
+          Done -> return Done
+  next (InSkip s_b) = return (Skip (InSkip s_b))
+{-# INLINE[1] bind_s #-}
+{-
 bind_s :: Monad m => StreamM m a -> (a -> StreamM m b) -> StreamM m b
 bind_s (StreamM next_a a0) f = StreamM next (Boundary a0) where
   {-# INLINE next #-}
@@ -363,13 +413,16 @@ bind_s (StreamM next_a a0) f = StreamM next (Boundary a0) where
     case x of
       Yield a as -> case f a of
         StreamM next_fa fa0 -> next (InProgress as next_fa fa0)
+      Skip as -> next (InSkip as)
       Done -> return Done
   next (InProgress s_a next_b s_b) = do
     x <- next_b s_b
     case x of
       Yield b bs -> return (Yield b (InProgress s_a next_b bs))
+      Skip bs -> return (Skip (InProgress s_a next_b bs))
       Done -> next (Boundary s_a)
-{-# INLINE[1] bind_s #-}
+  next (InSkip s_b) = return (Skip (InSkip s_b))
+-}
 
 #if !MIN_VERSION_base(4,13,0)
   {-# INLINEABLE fail #-}

From c797421169a343ca96537061c06d2c8856531d71 Mon Sep 17 00:00:00 2001
From: Jason Dagit <dagitj@gmail.com>
Date: Mon, 26 Jul 2021 11:12:26 -0700
Subject: [PATCH 3/8] Fix bind

---
 src/Control/Monad/Logic/Sequence/Internal.hs | 44 +++++---------------
 1 file changed, 11 insertions(+), 33 deletions(-)

diff --git a/src/Control/Monad/Logic/Sequence/Internal.hs b/src/Control/Monad/Logic/Sequence/Internal.hs
index de8410d..ace4ec5 100644
--- a/src/Control/Monad/Logic/Sequence/Internal.hs
+++ b/src/Control/Monad/Logic/Sequence/Internal.hs
@@ -364,45 +364,23 @@ done = StreamM (const (return Done)) Empty
 data BindSState a b m
   = Boundary a
   | forall s. InProgress a (s -> m (Step s b)) s
-  | forall s. InSkip s
 
--- I wanted to see how well `bind_s` fuses if `next` is not recursive.
--- That took a bit of rewriting and the result is quite ugly. It is
--- slightly faster, so I think that means it does fuse better, but
--- frankly, it's an awful mess.
 bind_s :: Monad m => StreamM m a -> (a -> StreamM m b) -> StreamM m b
 bind_s (StreamM next_a a0) f = StreamM next (Boundary a0) where
   {-# INLINE next #-}
   next (Boundary s_a) = do
     x <- next_a s_a
-    case x of
-      Yield a as -> case f a of
-        StreamM next_fa fa0 -> do
-          y <- next_fa fa0
-          case y of
-            Yield b bs -> return (Yield b (InProgress as next_fa bs))
-            Skip bs -> return (Skip (InProgress as next_fa bs))
-            Done -> return (Skip (InProgress as next_fa fa0))
-      Skip as -> return (Skip (InSkip as))
-      Done -> return Done
-  next (InProgress s_a next_b s_b) = do
-    x <- next_b s_b
-    case x of
-      Yield b bs -> return (Yield b (InProgress s_a next_b bs))
-      Skip bs -> return (Skip (InProgress s_a next_b bs))
-      Done -> do
-        z <- next_a s_a
-        case z of
-          Yield a as -> case f a of
-            StreamM next_fa fa0 -> do
-              y <- next_fa fa0
-              case y of
-                Yield b bs -> return (Yield b (InProgress as next_fa bs))
-                Skip bs -> return (Skip (InProgress as next_fa bs))
-                Done -> return (Skip (InProgress as next_fa fa0))
-          Skip as -> return (Skip (InSkip as))
-          Done -> return Done
-  next (InSkip s_b) = return (Skip (InSkip s_b))
+    return $ case x of
+      Yield a _ -> case f a of
+        StreamM next_fa fa0 -> Skip (InProgress s_a next_fa fa0)
+      Skip as -> Skip (Boundary as)
+      Done -> Done
+  next (InProgress s_a next_fa s_fa) = do
+    x <- next_fa s_fa
+    return $ case x of
+      Yield b bs -> Yield b (InProgress s_a next_fa bs)
+      Skip bs -> Skip (InProgress s_a next_fa bs)
+      Done -> Skip (Boundary s_a)
 {-# INLINE[1] bind_s #-}
 {-
 bind_s :: Monad m => StreamM m a -> (a -> StreamM m b) -> StreamM m b

From dd7fb893847adf3a2b5512cc94c8b0ff720e4798 Mon Sep 17 00:00:00 2001
From: Jason Dagit <dagitj@gmail.com>
Date: Mon, 26 Jul 2021 11:56:49 -0700
Subject: [PATCH 4/8] Clean up

---
 src/Control/Monad/Logic/Sequence.hs          |  1 +
 src/Control/Monad/Logic/Sequence/Internal.hs | 78 ++++----------------
 2 files changed, 17 insertions(+), 62 deletions(-)

diff --git a/src/Control/Monad/Logic/Sequence.hs b/src/Control/Monad/Logic/Sequence.hs
index 8c4e293..26292f3 100644
--- a/src/Control/Monad/Logic/Sequence.hs
+++ b/src/Control/Monad/Logic/Sequence.hs
@@ -30,6 +30,7 @@ module Control.Monad.Logic.Sequence
   , observeMany
   , observeT
   , observe
+  , chooseSeqT
   , module Control.Monad
   , module Control.Monad.Trans
 )
diff --git a/src/Control/Monad/Logic/Sequence/Internal.hs b/src/Control/Monad/Logic/Sequence/Internal.hs
index ace4ec5..196737e 100644
--- a/src/Control/Monad/Logic/Sequence/Internal.hs
+++ b/src/Control/Monad/Logic/Sequence/Internal.hs
@@ -51,11 +51,10 @@ module Control.Monad.Logic.Sequence.Internal
   , fromLogicT
   , chooseStreamM
   , chooseSeqT
-  , asumSeqT
 )
 where
 
-import Control.Applicative
+import Control.Applicative as A
 import Control.Monad
 import qualified Control.Monad.Fail as Fail
 import Control.Monad.Identity (Identity(..))
@@ -204,39 +203,8 @@ unstream (StreamM next s0) = fromView (unfold s0)
 
 {-# RULES
       "stream-unstream" [2] forall s. stream (unstream s) = s;
-      "toView-fromView" [1] forall s. fromView (toView s) = s;
   #-}
 
-newtype Fix1 f a = In1 { out1 :: f (Fix1 f a) a }
-
-chooseStreamM :: (Foldable f, Monad m) => f a -> StreamM m a
-chooseStreamM = StreamM (return . out1) . foldr (\a b -> In1 (Yield a b)) (In1 Done)
-{-# INLINE[1] chooseStreamM #-}
-
-chooseSeqT :: (Foldable f, Monad m) => f a -> SeqT m a
-chooseSeqT = unstream . chooseStreamM
-{-# INLINE[3] chooseSeqT #-}
-
-{-
-chooseSeqT :: (Foldable t, Monad m) => t a -> SeqT m a
-chooseSeqT xs = unstream (foldr (alt_s . stream . pure) done xs)
-{-# INLINEABLE [3] chooseSeqT #-}
-
-chooseSeqTList :: Monad m => [a] -> SeqT m a
-chooseSeqTList xs = unstream (StreamM next xs)
-  where
-  next [] = return Done
-  next (y:ys) = return (Yield y ys)
-{-# INLINEABLE [3] chooseSeqTList #-}
-
-{-# RULES
-    "chooseSeqT list" [4] chooseSeqT = chooseSeqTList;
-  #-}
--}
-asumSeqT :: (Monad m, Foldable t) => t (SeqT m a) -> SeqT m a
-asumSeqT = unstream . foldr (alt_s . stream) done
-{-# INLINE [3] asumSeqT #-}
-
 {-
 Theorem: toView . fromView = id
 
@@ -261,6 +229,16 @@ m >>= \x -> case x of
 = m
 -}
 
+newtype Fix1 f a = In1 { out1 :: f (Fix1 f a) a }
+
+chooseStreamM :: (Foldable f, Monad m) => f a -> StreamM m a
+chooseStreamM = StreamM (return . out1) . foldr (\a b -> In1 (Yield a b)) (In1 Done)
+{-# INLINE[1] chooseStreamM #-}
+
+chooseSeqT :: (Foldable f, Monad m) => f a -> SeqT m a
+chooseSeqT = unstream . chooseStreamM
+{-# INLINE[3] chooseSeqT #-}
+
 instance (Show (m (View m a)), Monad m) => Show (SeqT m a) where
   showsPrec d s = showParen (d > app_prec) $
       showString "MkSeqT " . showsPrec (app_prec + 1) (toView s)
@@ -352,15 +330,15 @@ instance Monad m => Monad (SeqT m) where
   {-# INLINEABLE (>>=) #-}
   return = fromView . single
   (>>=) = bind
+#if !MIN_VERSION_base(4,13,0)
+  {-# INLINEABLE fail #-}
+  fail = Fail.fail
+#endif
 
 bind :: Monad m => SeqT m a -> (a -> SeqT m b) -> SeqT m b
 bind m f = unstream (bind_s (stream m) (stream . f))
 {-# INLINE[3] bind #-}
 
-done :: Monad m => StreamM m a
-done = StreamM (const (return Done)) Empty
-{-# INLINE CONLIKE [0] done #-}
-
 data BindSState a b m
   = Boundary a
   | forall s. InProgress a (s -> m (Step s b)) s
@@ -382,30 +360,6 @@ bind_s (StreamM next_a a0) f = StreamM next (Boundary a0) where
       Skip bs -> Skip (InProgress s_a next_fa bs)
       Done -> Skip (Boundary s_a)
 {-# INLINE[1] bind_s #-}
-{-
-bind_s :: Monad m => StreamM m a -> (a -> StreamM m b) -> StreamM m b
-bind_s (StreamM next_a a0) f = StreamM next (Boundary a0) where
-  {-# INLINE next #-}
-  next (Boundary s_a) = do
-    x <- next_a s_a
-    case x of
-      Yield a as -> case f a of
-        StreamM next_fa fa0 -> next (InProgress as next_fa fa0)
-      Skip as -> next (InSkip as)
-      Done -> return Done
-  next (InProgress s_a next_b s_b) = do
-    x <- next_b s_b
-    case x of
-      Yield b bs -> return (Yield b (InProgress s_a next_b bs))
-      Skip bs -> return (Skip (InProgress s_a next_b bs))
-      Done -> next (Boundary s_a)
-  next (InSkip s_b) = return (Skip (InSkip s_b))
--}
-
-#if !MIN_VERSION_base(4,13,0)
-  {-# INLINEABLE fail #-}
-  fail = Fail.fail
-#endif
 
 instance Monad m => Fail.MonadFail (SeqT m) where
   {-# INLINEABLE fail #-}
@@ -414,7 +368,7 @@ instance Monad m => Fail.MonadFail (SeqT m) where
 instance Monad m => MonadPlus (SeqT m) where
   {-# INLINE mzero #-}
   {-# INLINE mplus #-}
-  mzero = Control.Applicative.empty
+  mzero = A.empty
   mplus = (<|>)
 
 #if MIN_VERSION_base(4,9,0)

From 6f20a830a160be49521311aab0e26f44e552892e Mon Sep 17 00:00:00 2001
From: Jason Dagit <dagitj@gmail.com>
Date: Mon, 26 Jul 2021 12:01:49 -0700
Subject: [PATCH 5/8] Make old GHCs happy

---
 src/Control/Monad/Logic/Sequence/Internal.hs | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

diff --git a/src/Control/Monad/Logic/Sequence/Internal.hs b/src/Control/Monad/Logic/Sequence/Internal.hs
index 196737e..bf74006 100644
--- a/src/Control/Monad/Logic/Sequence/Internal.hs
+++ b/src/Control/Monad/Logic/Sequence/Internal.hs
@@ -231,11 +231,11 @@ m >>= \x -> case x of
 
 newtype Fix1 f a = In1 { out1 :: f (Fix1 f a) a }
 
-chooseStreamM :: (Foldable f, Monad m) => f a -> StreamM m a
+chooseStreamM :: (F.Foldable f, Monad m) => f a -> StreamM m a
 chooseStreamM = StreamM (return . out1) . foldr (\a b -> In1 (Yield a b)) (In1 Done)
 {-# INLINE[1] chooseStreamM #-}
 
-chooseSeqT :: (Foldable f, Monad m) => f a -> SeqT m a
+chooseSeqT :: (F.Foldable f, Monad m) => f a -> SeqT m a
 chooseSeqT = unstream . chooseStreamM
 {-# INLINE[3] chooseSeqT #-}
 

From 44a91efa7d1ceba412fdee535e38fc90498f482c Mon Sep 17 00:00:00 2001
From: Jason Dagit <dagitj@gmail.com>
Date: Mon, 26 Jul 2021 12:41:34 -0700
Subject: [PATCH 6/8] Make old GHCs happy

---
 src/Control/Monad/Logic/Sequence/Internal.hs | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/src/Control/Monad/Logic/Sequence/Internal.hs b/src/Control/Monad/Logic/Sequence/Internal.hs
index bf74006..d374e2a 100644
--- a/src/Control/Monad/Logic/Sequence/Internal.hs
+++ b/src/Control/Monad/Logic/Sequence/Internal.hs
@@ -232,7 +232,7 @@ m >>= \x -> case x of
 newtype Fix1 f a = In1 { out1 :: f (Fix1 f a) a }
 
 chooseStreamM :: (F.Foldable f, Monad m) => f a -> StreamM m a
-chooseStreamM = StreamM (return . out1) . foldr (\a b -> In1 (Yield a b)) (In1 Done)
+chooseStreamM = StreamM (return . out1) . F.foldr (\a b -> In1 (Yield a b)) (In1 Done)
 {-# INLINE[1] chooseStreamM #-}
 
 chooseSeqT :: (F.Foldable f, Monad m) => f a -> SeqT m a

From 129703508133e23827eb7f2dbd5d0910c675ce28 Mon Sep 17 00:00:00 2001
From: Jason Dagit <dagitj@gmail.com>
Date: Mon, 26 Jul 2021 13:04:32 -0700
Subject: [PATCH 7/8] Make fmap fusable

---
 src/Control/Monad/Logic/Sequence/Internal.hs | 20 +++++++++++++++++---
 1 file changed, 17 insertions(+), 3 deletions(-)

diff --git a/src/Control/Monad/Logic/Sequence/Internal.hs b/src/Control/Monad/Logic/Sequence/Internal.hs
index d374e2a..688abb6 100644
--- a/src/Control/Monad/Logic/Sequence/Internal.hs
+++ b/src/Control/Monad/Logic/Sequence/Internal.hs
@@ -277,9 +277,23 @@ single a = return (a :< mzero)
 
 instance Monad m => Functor (SeqT m) where
   {-# INLINEABLE fmap #-}
-  fmap f (SeqT q) = SeqT $ fmap (liftM (fmap f)) q
-  {-# INLINABLE (<$) #-}
-  x <$ SeqT q = SeqT $ fmap (liftM (x <$)) q
+  fmap = fmapSeqT
+
+fmapSeqT :: Monad m => (a -> b) -> SeqT m a -> SeqT m b
+fmapSeqT f s = unstream (fmap_s f (stream s))
+{-# INLINEABLE [3] fmapSeqT #-}
+
+fmap_s :: Monad m => (a -> b) -> StreamM m a -> StreamM m b
+fmap_s f (StreamM next_a a0) = StreamM next a0
+  where
+  {-# INLINE next #-}
+  next a = do
+    x <- next_a a
+    case x of
+      Done -> return Done
+      Skip s -> return (Skip s)
+      Yield y ys -> return (Yield (f y) ys)
+{-# INLINEABLE [1] fmap_s #-}
 
 instance Monad m => Applicative (SeqT m) where
   {-# INLINE pure #-}

From 9ad78e71eee3cf2612a5c7092eea1e29822ed50e Mon Sep 17 00:00:00 2001
From: Jason Dagit <dagitj@gmail.com>
Date: Sat, 31 Jul 2021 11:21:30 -0700
Subject: [PATCH 8/8] Tests will fail but at least they won't loop

---
 src/Control/Monad/Logic/Sequence/Internal.hs | 4 ++++
 1 file changed, 4 insertions(+)

diff --git a/src/Control/Monad/Logic/Sequence/Internal.hs b/src/Control/Monad/Logic/Sequence/Internal.hs
index 688abb6..d2bfd9d 100644
--- a/src/Control/Monad/Logic/Sequence/Internal.hs
+++ b/src/Control/Monad/Logic/Sequence/Internal.hs
@@ -359,6 +359,9 @@ data BindSState a b m
 
 bind_s :: Monad m => StreamM m a -> (a -> StreamM m b) -> StreamM m b
 bind_s (StreamM next_a a0) f = StreamM next (Boundary a0) where
+  next _ = return undefined
+-- TODO: fixme: this is an infinite loop right now
+{-
   {-# INLINE next #-}
   next (Boundary s_a) = do
     x <- next_a s_a
@@ -373,6 +376,7 @@ bind_s (StreamM next_a a0) f = StreamM next (Boundary a0) where
       Yield b bs -> Yield b (InProgress s_a next_fa bs)
       Skip bs -> Skip (InProgress s_a next_fa bs)
       Done -> Skip (Boundary s_a)
+-}
 {-# INLINE[1] bind_s #-}
 
 instance Monad m => Fail.MonadFail (SeqT m) where