{-# LANGUAGE CPP #-}
#include "logict-sequence.h"
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveTraversable #-}
#if __GLASGOW_HASKELL__ < 710
{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveFunctor #-}
#endif
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}

#ifdef USE_PATTERN_SYNONYMS
{-# LANGUAGE PatternSynonyms #-}
#endif

{-# LANGUAGE Trustworthy #-}
{-# OPTIONS_HADDOCK not-home #-}
#if __GLASGOW_HASKELL__ >= 902
-- We need this for now to work around
-- https://gitlab.haskell.org/ghc/ghc/-/issues/22549 which otherwise causes
-- infinite loops in several instances. It's definitely needed for GHC 9.4; we
-- do it for 9.2 as well just in case, as others have gotten loops with
-- -fdicts-strict with that version.
{-# OPTIONS_GHC -fno-dicts-strict #-}
#endif

{- OPTIONS_GHC -ddump-simpl -dsuppress-coercions #-}

-- | Based on the LogicT improvements in the paper, Reflection without
-- Remorse. Code is based on the code provided in:
-- https://github.com/atzeus/reflectionwithoutremorse
--
-- Note: that code is provided under an MIT license, so we use that as
-- well.
module Control.Monad.Logic.Sequence.Internal
(
#ifdef USE_PATTERN_SYNONYMS
    SeqT(MkSeqT, getSeqT, ..)
#else
    SeqT(..)
#endif
  , Seq
#ifdef USE_PATTERN_SYNONYMS
  , pattern MkSeq
  , getSeq
#endif
  , ViewT(..)
  , View
  , viewT
  , view
  , toViewT
  , toView
  , fromViewT
  , fromView
  , observeAllT
  , observeAll
  , observeManyT
  , observeMany
  , observeT
  , observe
  , fromSeqT
  , hoistPre
  , hoistPost
  , hoistPreUnexposed
  , hoistPostUnexposed
  , toLogicT
  , fromLogicT
  , cons
  , consM
  , choose
  , chooseM
)
where

import Control.Applicative
import Control.Monad hiding (liftM)
#if !MIN_VERSION_base(4,8,0)
import qualified Control.Monad as Monad
#endif
import qualified Control.Monad.Fail as Fail
import Control.Monad.Identity (Identity(..))
import Control.Monad.Trans (MonadTrans(..))
import Control.Monad.Logic.Class
import qualified Control.Monad.Logic as L
import Control.Monad.IO.Class
import Control.Monad.Reader.Class (MonadReader (..))
import Control.Monad.State.Class (MonadState (..))
import Control.Monad.Error.Class (MonadError (..))
import Control.Monad.Morph (MFunctor (..))
import qualified Data.SequenceClass as S
import Control.Monad.Logic.Sequence.Internal.Queue (Queue)
#if MIN_VERSION_base(4,8,0)
import Control.Monad.Zip (MonadZip (..))
#endif
import qualified Text.Read as TR
import Data.Function (on)
#if MIN_VERSION_base(4,9,0)
import Data.Functor.Classes
#endif

#if !MIN_VERSION_base(4,8,0)
import Data.Monoid (Monoid(..))
#endif

#if MIN_VERSION_base(4,9,0)
import Data.Semigroup (Semigroup(..))
#endif

import qualified Data.Foldable as F
import qualified Data.Traversable as T
import GHC.Generics (Generic)
import Data.Coerce (coerce)

-- | A view of the front end of a 'SeqT'.
data ViewT m a = Empty | a :< SeqT m a
  deriving forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall (m :: * -> *) a x. Rep (ViewT m a) x -> ViewT m a
forall (m :: * -> *) a x. ViewT m a -> Rep (ViewT m a) x
$cto :: forall (m :: * -> *) a x. Rep (ViewT m a) x -> ViewT m a
$cfrom :: forall (m :: * -> *) a x. ViewT m a -> Rep (ViewT m a) x
Generic
infixl 5 :<

type View = ViewT Identity

-- | A catamorphism for 'ViewT's
viewT :: b -> (a -> SeqT m a -> b) -> ViewT m a -> b
viewT :: forall b a (m :: * -> *).
b -> (a -> SeqT m a -> b) -> ViewT m a -> b
viewT b
n a -> SeqT m a -> b
_ ViewT m a
Empty = b
n
viewT b
_ a -> SeqT m a -> b
c (a
a :< SeqT m a
s) = a -> SeqT m a -> b
c a
a SeqT m a
s
{-# INLINE viewT #-}

-- | A catamorphism for 'View's. Note that this is just a type-restricted version
-- of 'viewT'.
view :: b -> (a -> Seq a -> b) -> View a -> b
view :: forall b a. b -> (a -> Seq a -> b) -> View a -> b
view = forall b a (m :: * -> *).
b -> (a -> SeqT m a -> b) -> ViewT m a -> b
viewT
{-# INLINE view #-}

deriving instance (Show a, Show (SeqT m a)) => Show (ViewT m a)
deriving instance (Read a, Read (SeqT m a)) => Read (ViewT m a)
deriving instance (Eq a, Eq (SeqT m a)) => Eq (ViewT m a)
deriving instance (Ord a, Ord (SeqT m a)) => Ord (ViewT m a)
deriving instance Monad m => Functor (ViewT m)
deriving instance (Monad m, F.Foldable m) => F.Foldable (ViewT m)
instance (Monad m, T.Traversable m) => T.Traversable (ViewT m) where
  traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> ViewT m a -> f (ViewT m b)
traverse a -> f b
_ ViewT m a
Empty = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall (m :: * -> *) a. ViewT m a
Empty
  traverse a -> f b
f (a
x :< SeqT m a
xs) =
    forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 (\b
y m (ViewT m b)
ys -> b
y forall (m :: * -> *) a. a -> SeqT m a -> ViewT m a
:< forall (m :: * -> *) a. m (ViewT m a) -> SeqT m a
fromViewT m (ViewT m b)
ys) (a -> f b
f a
x) (forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
T.traverse (forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
T.traverse a -> f b
f) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. Monad m => SeqT m a -> m (ViewT m a)
toViewT forall a b. (a -> b) -> a -> b
$ SeqT m a
xs)
--  The derived instance would use
--
--    traverse f (x :< xs) = liftA2 (:<) (f x) (traverse f xs)
--
--  Inlining the inner `traverse` reveals an application of `fmap` which
--  we fuse with `liftA2`, in case `fmap` isn't free.

#if MIN_VERSION_base(4,9,0)
instance (Eq1 m, Monad m) => Eq1 (ViewT m) where
  liftEq :: forall a b. (a -> b -> Bool) -> ViewT m a -> ViewT m b -> Bool
liftEq a -> b -> Bool
_ ViewT m a
Empty ViewT m b
Empty = Bool
True
  liftEq a -> b -> Bool
eq (a
a :< SeqT m a
s) (b
b :< SeqT m b
t) = a -> b -> Bool
eq a
a b
b Bool -> Bool -> Bool
&& forall (f :: * -> *) a b.
Eq1 f =>
(a -> b -> Bool) -> f a -> f b -> Bool
liftEq a -> b -> Bool
eq SeqT m a
s SeqT m b
t
  liftEq a -> b -> Bool
_ ViewT m a
_ ViewT m b
_ = Bool
False

instance (Ord1 m, Monad m) => Ord1 (ViewT m) where
  liftCompare :: forall a b.
(a -> b -> Ordering) -> ViewT m a -> ViewT m b -> Ordering
liftCompare a -> b -> Ordering
_ ViewT m a
Empty ViewT m b
Empty = Ordering
EQ
  liftCompare a -> b -> Ordering
_ ViewT m a
Empty (b
_ :< SeqT m b
_) = Ordering
LT
  liftCompare a -> b -> Ordering
cmp (a
a :< SeqT m a
s) (b
b :< SeqT m b
t) = a -> b -> Ordering
cmp a
a b
b forall a. Monoid a => a -> a -> a
`mappend` forall (f :: * -> *) a b.
Ord1 f =>
(a -> b -> Ordering) -> f a -> f b -> Ordering
liftCompare a -> b -> Ordering
cmp SeqT m a
s SeqT m b
t
  liftCompare a -> b -> Ordering
_ (a
_ :< SeqT m a
_) ViewT m b
Empty = Ordering
GT

instance (Show1 m, Monad m) => Show1 (ViewT m) where
  liftShowsPrec :: forall a.
(Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> ViewT m a -> ShowS
liftShowsPrec Int -> a -> ShowS
sp [a] -> ShowS
sl Int
d ViewT m a
val = case ViewT m a
val of
    ViewT m a
Empty -> (String
"Empty" forall a. [a] -> [a] -> [a]
++)
    a
a :< SeqT m a
s -> Bool -> ShowS -> ShowS
showParen (Int
d forall a. Ord a => a -> a -> Bool
> Int
5) forall a b. (a -> b) -> a -> b
$
      Int -> a -> ShowS
sp Int
6 a
a forall b c a. (b -> c) -> (a -> b) -> a -> c
.
      String -> ShowS
showString String
" :< " forall b c a. (b -> c) -> (a -> b) -> a -> c
.
      forall (f :: * -> *) a.
Show1 f =>
(Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> f a -> ShowS
liftShowsPrec Int -> a -> ShowS
sp [a] -> ShowS
sl Int
6 SeqT m a
s
#endif

-- | An asymptotically efficient logic monad transformer. It is generally best to
-- think of this as being defined
--
-- @
-- newtype SeqT m a = 'MkSeqT' { 'getSeqT' :: m ('ViewT' m a) }
-- @
--
-- Using the 'MkSeqT' pattern synonym with 'getSeqT', you can (almost) pretend
-- 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 (ViewT m a)))

#ifdef USE_PATTERN_SYNONYMS
pattern MkSeqT :: Monad m => m (ViewT m a) -> SeqT m a
pattern $bMkSeqT :: forall (m :: * -> *) a. Monad m => m (ViewT m a) -> SeqT m a
$mMkSeqT :: forall {r} {m :: * -> *} {a}.
Monad m =>
SeqT m a -> (m (ViewT m a) -> r) -> ((# #) -> r) -> r
MkSeqT{forall (m :: * -> *) a. Monad m => SeqT m a -> m (ViewT m a)
getSeqT} <- (toViewT -> getSeqT)
  where
    MkSeqT = forall (m :: * -> *) a. m (ViewT m a) -> SeqT m a
fromViewT
{-# COMPLETE MkSeqT #-}

pattern MkSeq :: View a -> Seq a
pattern $bMkSeq :: forall a. View a -> Seq a
$mMkSeq :: forall {r} {a}. Seq a -> (View a -> r) -> ((# #) -> r) -> r
MkSeq{forall a. Seq a -> View a
getSeq} = MkSeqT (Identity getSeq)
{-# COMPLETE MkSeq #-}
#endif

-- | A specialization of 'SeqT' to the 'Identity' monad. You can
-- imagine that this is defined
--
-- @
-- newtype Seq a = MkSeq { getSeq :: ViewT Identity a }
-- @
--
-- Using the 'MkSeq' pattern synonym with 'getSeq', you can pretend 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.
type Seq = SeqT Identity

fromViewT :: m (ViewT m a) -> SeqT m a
fromViewT :: forall (m :: * -> *) a. m (ViewT m a) -> SeqT m a
fromViewT = forall (m :: * -> *) a. Queue (m (ViewT m a)) -> SeqT m a
SeqT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (s :: * -> *) c. Sequence s => c -> s c
S.singleton
{-# INLINABLE [1] fromViewT #-}

fromView :: forall a. View a -> Seq a
fromView :: forall a. View a -> Seq a
fromView = coerce :: forall a b. Coercible a b => a -> b
coerce (forall (m :: * -> *) a. m (ViewT m a) -> SeqT m a
fromViewT :: Identity (View a) -> Seq a)
{-# INLINE fromView #-}

toViewT :: Monad m => SeqT m a -> m (ViewT m a)
toViewT :: forall (m :: * -> *) a. Monad m => SeqT m a -> m (ViewT m a)
toViewT (SeqT Queue (m (ViewT m a))
s) = case forall (s :: * -> *) c. Sequence s => s c -> ViewL s c
S.viewl Queue (m (ViewT m a))
s of
  ViewL Queue (m (ViewT m a))
S.EmptyL -> forall (m :: * -> *) a. Monad m => a -> m a
return forall (m :: * -> *) a. ViewT m a
Empty
  m (ViewT m a)
h S.:< Queue (m (ViewT m a))
t -> m (ViewT m a)
h forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ViewT m a
x -> case ViewT m a
x of
    ViewT m a
Empty -> forall (m :: * -> *) a. Monad m => SeqT m a -> m (ViewT m a)
toViewT (forall (m :: * -> *) a. Queue (m (ViewT m a)) -> SeqT m a
SeqT Queue (m (ViewT m a))
t)
    a
hi :< SeqT Queue (m (ViewT m a))
ti -> forall (m :: * -> *) a. Monad m => a -> m a
return (a
hi forall (m :: * -> *) a. a -> SeqT m a -> ViewT m a
:< forall (m :: * -> *) a. Queue (m (ViewT m a)) -> SeqT m a
SeqT (Queue (m (ViewT m a))
ti forall (s :: * -> *) c. Sequence s => s c -> s c -> s c
S.>< Queue (m (ViewT m a))
t))
{-# INLINEABLE [1] toViewT #-}

toView :: forall a. Seq a -> View a
toView :: forall a. Seq a -> View a
toView = coerce :: forall a b. Coercible a b => a -> b
coerce (forall (m :: * -> *) a. Monad m => SeqT m a -> m (ViewT m a)
toViewT :: SeqT Identity a -> Identity (ViewT Identity a))
{-# INLINABLE toView #-}

-- For now, we don't assume the monad identity law holds for the underlying
-- monad. We may re-evaluate that later, but it's a bit tricky to document the
-- detailed strictness requirements properly.
--
-- We do, however, assume that `pure /= _|_`, or that `>>=` doesn't `seq` on
-- its second argument, and that we can therefore eta-reduce `\x -> pure x` to
-- just `pure`. It seems quite safe to assume that at least one of these is
-- true, since in real code they're virtually always *both* true.
{-# RULES
"toViewT . fromViewT" forall m. toViewT (fromViewT m) = m >>= return
 #-}

{-
Theorem: toViewT . fromViewT = id

Proof:

toViewT (fromViewT m)
=
toViewT (SeqT (singleton m))
=
case viewl (singleton m) of
    h S.:< t -> h >>= \x -> case x of
      Empty -> toViewT (SeqT t)
      hi :< SeqT ti -> return (hi :< SeqT (ti S.>< t))
=
m >>= \x -> case x of
  Empty -> toViewT (SeqT S.empty)
  hi :< SeqT ti -> return (hi :< SeqT ti)
=
m >>= \x -> case x of
  Empty -> return Empty
  hi :< SeqT ti -> return (hi :< SeqT ti)
= m >>= \x -> return x
= m -- assuming the appropriate identity law holds for the underlying monad.
-}

instance (Show (m (ViewT m a)), Monad m) => Show (SeqT m a) where
  showsPrec :: Int -> SeqT m a -> ShowS
showsPrec Int
d SeqT m a
s = Bool -> ShowS -> ShowS
showParen (Int
d forall a. Ord a => a -> a -> Bool
> Int
app_prec) forall a b. (a -> b) -> a -> b
$
      String -> ShowS
showString String
"MkSeqT " forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => Int -> a -> ShowS
showsPrec (Int
app_prec forall a. Num a => a -> a -> a
+ Int
1) (forall (m :: * -> *) a. Monad m => SeqT m a -> m (ViewT m a)
toViewT SeqT m a
s)
    where app_prec :: Int
app_prec = Int
10

instance Read (m (ViewT m a)) => Read (SeqT m a) where
  readPrec :: ReadPrec (SeqT m a)
readPrec = forall a. ReadPrec a -> ReadPrec a
TR.parens forall a b. (a -> b) -> a -> b
$ forall a. Int -> ReadPrec a -> ReadPrec a
TR.prec Int
app_prec forall a b. (a -> b) -> a -> b
$ do
      TR.Ident String
"MkSeqT" <- ReadPrec Lexeme
TR.lexP
      m (ViewT m a)
m <- forall a. ReadPrec a -> ReadPrec a
TR.step forall a. Read a => ReadPrec a
TR.readPrec
      forall (m :: * -> *) a. Monad m => a -> m a
return (forall (m :: * -> *) a. m (ViewT m a) -> SeqT m a
fromViewT m (ViewT m a)
m)
    where app_prec :: Int
app_prec = Int
10
  readListPrec :: ReadPrec [SeqT m a]
readListPrec = forall a. Read a => ReadPrec [a]
TR.readListPrecDefault

instance (Eq a, Eq (m (ViewT m a)), Monad m) => Eq (SeqT m a) where
  == :: SeqT m a -> SeqT m a -> Bool
(==) = forall a. Eq a => a -> a -> Bool
(==) forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` forall (m :: * -> *) a. Monad m => SeqT m a -> m (ViewT m a)
toViewT
instance (Ord a, Ord (m (ViewT m a)), Monad m) => Ord (SeqT m a) where
  compare :: SeqT m a -> SeqT m a -> Ordering
compare = forall a. Ord a => a -> a -> Ordering
compare forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` forall (m :: * -> *) a. Monad m => SeqT m a -> m (ViewT m a)
toViewT


#if MIN_VERSION_base(4,9,0)
instance (Eq1 m, Monad m) => Eq1 (SeqT m) where
  liftEq :: forall a b. (a -> b -> Bool) -> SeqT m a -> SeqT m b -> Bool
liftEq a -> b -> Bool
eq SeqT m a
s SeqT m b
t = forall (f :: * -> *) a b.
Eq1 f =>
(a -> b -> Bool) -> f a -> f b -> Bool
liftEq (forall (f :: * -> *) a b.
Eq1 f =>
(a -> b -> Bool) -> f a -> f b -> Bool
liftEq a -> b -> Bool
eq) (forall (m :: * -> *) a. Monad m => SeqT m a -> m (ViewT m a)
toViewT SeqT m a
s) (forall (m :: * -> *) a. Monad m => SeqT m a -> m (ViewT m a)
toViewT SeqT m b
t)

instance (Ord1 m, Monad m) => Ord1 (SeqT m) where
  liftCompare :: forall a b.
(a -> b -> Ordering) -> SeqT m a -> SeqT m b -> Ordering
liftCompare a -> b -> Ordering
eq SeqT m a
s SeqT m b
t = forall (f :: * -> *) a b.
Ord1 f =>
(a -> b -> Ordering) -> f a -> f b -> Ordering
liftCompare (forall (f :: * -> *) a b.
Ord1 f =>
(a -> b -> Ordering) -> f a -> f b -> Ordering
liftCompare a -> b -> Ordering
eq) (forall (m :: * -> *) a. Monad m => SeqT m a -> m (ViewT m a)
toViewT SeqT m a
s) (forall (m :: * -> *) a. Monad m => SeqT m a -> m (ViewT m a)
toViewT SeqT m b
t)

instance (Show1 m, Monad m) => Show1 (SeqT m) where
  liftShowsPrec :: forall a.
(Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> SeqT m a -> ShowS
liftShowsPrec Int -> a -> ShowS
sp [a] -> ShowS
sl Int
d SeqT m a
s = Bool -> ShowS -> ShowS
showParen (Int
d forall a. Ord a => a -> a -> Bool
> Int
app_prec) forall a b. (a -> b) -> a -> b
$
      String -> ShowS
showString String
"MkSeqT " forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a.
Show1 f =>
(Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> f a -> ShowS
liftShowsPrec (forall (f :: * -> *) a.
Show1 f =>
(Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> f a -> ShowS
liftShowsPrec Int -> a -> ShowS
sp [a] -> ShowS
sl) (forall (f :: * -> *) a.
Show1 f =>
(Int -> a -> ShowS) -> ([a] -> ShowS) -> [f a] -> ShowS
liftShowList Int -> a -> ShowS
sp [a] -> ShowS
sl) (Int
app_prec forall a. Num a => a -> a -> a
+ Int
1) (forall (m :: * -> *) a. Monad m => SeqT m a -> m (ViewT m a)
toViewT SeqT m a
s)
    where app_prec :: Int
app_prec = Int
10
#endif

single :: Monad m => a -> m (ViewT m a)
single :: forall (m :: * -> *) a. Monad m => a -> m (ViewT m a)
single a
a = forall (m :: * -> *) a. Monad m => a -> m a
return (a
a forall (m :: * -> *) a. a -> SeqT m a -> ViewT m a
:< forall (m :: * -> *) a. MonadPlus m => m a
mzero)
{-# INLINE single #-}

instance Monad m => Functor (SeqT m) where
  {-# INLINEABLE fmap #-}
  fmap :: forall a b. (a -> b) -> SeqT m a -> SeqT m b
fmap a -> b
f (SeqT Queue (m (ViewT m a))
q) = forall (m :: * -> *) a. Queue (m (ViewT m a)) -> SeqT m a
SeqT forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (m :: * -> *) a b. Functor m => (a -> b) -> m a -> m b
myliftM (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f)) Queue (m (ViewT m a))
q
  {-# INLINABLE (<$) #-}
  a
x <$ :: forall a b. a -> SeqT m b -> SeqT m a
<$ SeqT Queue (m (ViewT m b))
q = forall (m :: * -> *) a. Queue (m (ViewT m a)) -> SeqT m a
SeqT forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (m :: * -> *) a b. Functor m => (a -> b) -> m a -> m b
myliftM (a
x forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$)) Queue (m (ViewT m b))
q

instance Monad m => Applicative (SeqT m) where
  {-# INLINE pure #-}
  {-# INLINABLE (<*>) #-}
  pure :: forall a. a -> SeqT m a
pure = forall (m :: * -> *) a. m (ViewT m a) -> SeqT m a
fromViewT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. Monad m => a -> m (ViewT m a)
single

#if MIN_VERSION_base(4,8,0)
  SeqT m (a -> b)
fs <*> :: forall a b. SeqT m (a -> b) -> SeqT m a -> SeqT m b
<*> SeqT m a
xs = SeqT m (a -> b)
fs forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \a -> b
f -> a -> b
f forall (m :: * -> *) a b. Functor m => (a -> b) -> m a -> m b
<$> SeqT m a
xs
#else
  (<*>) = ap
#endif

  {-# INLINABLE (*>) #-}
  (forall (m :: * -> *) a. Monad m => SeqT m a -> m (ViewT m a)
toViewT -> m (ViewT m a)
m) *> :: forall a b. SeqT m a -> SeqT m b -> SeqT m b
*> SeqT m b
n = forall (m :: * -> *) a. m (ViewT m a) -> SeqT m a
fromViewT forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a b.
Monad m =>
m (ViewT m a) -> SeqT m b -> m (ViewT m b)
thenViewT m (ViewT m a)
m SeqT m b
n

#if MIN_VERSION_base(4,10,0)
  liftA2 :: forall a b c. (a -> b -> c) -> SeqT m a -> SeqT m b -> SeqT m c
liftA2 a -> b -> c
f SeqT m a
xs SeqT m b
ys = SeqT m a
xs forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \a
x -> a -> b -> c
f a
x forall (m :: * -> *) a b. Functor m => (a -> b) -> m a -> m b
<$> SeqT m b
ys
  {-# INLINABLE liftA2 #-}
#endif

thenViewT :: Monad m => m (ViewT m a) -> SeqT m b -> m (ViewT m b)
thenViewT :: forall (m :: * -> *) a b.
Monad m =>
m (ViewT m a) -> SeqT m b -> m (ViewT m b)
thenViewT m (ViewT m a)
m SeqT m b
n = m (ViewT m a)
m forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ViewT m a
x -> case ViewT m a
x of
  ViewT m a
Empty -> forall (m :: * -> *) a. Monad m => a -> m a
return forall (m :: * -> *) a. ViewT m a
Empty
  a
_ :< SeqT m a
t -> forall (m :: * -> *) a. Monad m => SeqT m a -> m (ViewT m a)
toViewT SeqT m b
n forall (m :: * -> *) a.
Monad m =>
m (ViewT m a) -> SeqT m a -> m (ViewT m a)
`altViewT` (SeqT m a
t forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> SeqT m b
n)
{-# INLINABLE thenViewT #-}

instance Monad m => Alternative (SeqT m) where
  {-# INLINE empty #-}
  {-# INLINEABLE (<|>) #-}
  empty :: forall a. SeqT m a
empty = forall (m :: * -> *) a. Queue (m (ViewT m a)) -> SeqT m a
SeqT forall (s :: * -> *) c. Sequence s => s c
S.empty
  SeqT Queue (m (ViewT m a))
m <|> :: forall a. SeqT m a -> SeqT m a -> SeqT m a
<|> SeqT Queue (m (ViewT m a))
n = forall (m :: * -> *) a. Queue (m (ViewT m a)) -> SeqT m a
SeqT (Queue (m (ViewT m a))
m forall (s :: * -> *) c. Sequence s => s c -> s c -> s c
S.>< Queue (m (ViewT m a))
n)

-- |
-- @
-- altViewT s t = toViewT (fromViewT s <|> t)
-- @
--
-- Question: is this actually good for optimization?
altViewT :: Monad m => m (ViewT m a) -> SeqT m a -> m (ViewT m a)
altViewT :: forall (m :: * -> *) a.
Monad m =>
m (ViewT m a) -> SeqT m a -> m (ViewT m a)
altViewT m (ViewT m a)
m SeqT m a
n = m (ViewT m a)
m forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ViewT m a
x -> case ViewT m a
x of
  ViewT m a
Empty -> forall (m :: * -> *) a. Monad m => SeqT m a -> m (ViewT m a)
toViewT SeqT m a
n
  a
h :< SeqT m a
t -> forall (m :: * -> *) a. Monad m => a -> m a
return (a
h forall (m :: * -> *) a. a -> SeqT m a -> ViewT m a
:< (SeqT m a
t forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> SeqT m a
n))
{-# INLINABLE altViewT #-}

-- | @cons a s = pure a <|> s@
cons :: Monad m => a -> SeqT m a -> SeqT m a
cons :: forall (m :: * -> *) a. Monad m => a -> SeqT m a -> SeqT m a
cons a
a SeqT m a
s = forall (m :: * -> *) a. m (ViewT m a) -> SeqT m a
fromViewT (forall (m :: * -> *) a. Monad m => a -> m a
return (a
a forall (m :: * -> *) a. a -> SeqT m a -> ViewT m a
:< SeqT m a
s))
{-# INLINE cons #-}

-- | @consM m s = lift m <|> s@
consM :: Monad m => m a -> SeqT m a -> SeqT m a
consM :: forall (m :: * -> *) a. Monad m => m a -> SeqT m a -> SeqT m a
consM m a
m SeqT m a
s = forall (m :: * -> *) a. m (ViewT m a) -> SeqT m a
fromViewT (forall (m :: * -> *) a b. Functor m => (a -> b) -> m a -> m b
myliftM (forall (m :: * -> *) a. a -> SeqT m a -> ViewT m a
:< SeqT m a
s) m a
m)
{-# INLINE consM #-}

instance Monad m => Monad (SeqT m) where
  {-# INLINE return #-}
  {-# INLINABLE (>>=) #-}
  return :: forall a. a -> SeqT m a
return = forall (f :: * -> *) a. Applicative f => a -> f a
pure
  (forall (m :: * -> *) a. Monad m => SeqT m a -> m (ViewT m a)
toViewT -> m (ViewT m a)
m) >>= :: forall a b. SeqT m a -> (a -> SeqT m b) -> SeqT m b
>>= a -> SeqT m b
f = forall (m :: * -> *) a. m (ViewT m a) -> SeqT m a
fromViewT forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a b.
Monad m =>
m (ViewT m a) -> (a -> SeqT m b) -> m (ViewT m b)
bindViewT m (ViewT m a)
m a -> SeqT m b
f
  >> :: forall a b. SeqT m a -> SeqT m b -> SeqT m b
(>>) = forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
(*>)

#if !MIN_VERSION_base(4,13,0)
  {-# INLINEABLE fail #-}
  fail = Fail.fail
#endif

bindViewT :: Monad m => m (ViewT m a) -> (a -> SeqT m b) -> m (ViewT m b)
bindViewT :: forall (m :: * -> *) a b.
Monad m =>
m (ViewT m a) -> (a -> SeqT m b) -> m (ViewT m b)
bindViewT m (ViewT m a)
m a -> SeqT m b
f = m (ViewT m a)
m forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ViewT m a
x -> case ViewT m a
x of
  ViewT m a
Empty -> forall (m :: * -> *) a. Monad m => a -> m a
return forall (m :: * -> *) a. ViewT m a
Empty
  a
h :< SeqT m a
t -> forall (m :: * -> *) a. Monad m => SeqT m a -> m (ViewT m a)
toViewT (a -> SeqT m b
f a
h) forall (m :: * -> *) a.
Monad m =>
m (ViewT m a) -> SeqT m a -> m (ViewT m a)
`altViewT` (SeqT m a
t forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= a -> SeqT m b
f)
{-# INLINABLE bindViewT #-}

instance Monad m => Fail.MonadFail (SeqT m) where
  {-# INLINEABLE fail #-}
  fail :: forall a. String -> SeqT m a
fail String
_ = forall (m :: * -> *) a. Queue (m (ViewT m a)) -> SeqT m a
SeqT forall (s :: * -> *) c. Sequence s => s c
S.empty

instance Monad m => MonadPlus (SeqT m) where
  {-# INLINE mzero #-}
  {-# INLINE mplus #-}
  mzero :: forall a. SeqT m a
mzero = forall (f :: * -> *) a. Alternative f => f a
Control.Applicative.empty
  mplus :: forall a. SeqT m a -> SeqT m a -> SeqT m a
mplus = forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
(<|>)

#if MIN_VERSION_base(4,9,0)
instance Monad m => Semigroup (SeqT m a) where
  {-# INLINE (<>) #-}
  {-# INLINE sconcat #-}
  <> :: SeqT m a -> SeqT m a -> SeqT m a
(<>) = forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
mplus
  sconcat :: NonEmpty (SeqT m a) -> SeqT m a
sconcat = forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
F.asum
#endif

instance Monad m => Monoid (SeqT m a) where
  {-# INLINE mempty #-}
  {-# INLINE mconcat #-}
  mempty :: SeqT m a
mempty = forall (m :: * -> *) a. Queue (m (ViewT m a)) -> SeqT m a
SeqT forall (s :: * -> *) c. Sequence s => s c
S.empty
  mconcat :: [SeqT m a] -> SeqT m a
mconcat = forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
F.asum
#if !MIN_VERSION_base(4,11,0)
  {-# INLINE mappend #-}
  mappend = (<|>)
#endif

instance MonadTrans SeqT where
  {-# INLINE lift #-}
  lift :: forall (m :: * -> *) a. Monad m => m a -> SeqT m a
lift m a
m = forall (m :: * -> *) a. m (ViewT m a) -> SeqT m a
fromViewT (m a
m forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a. Monad m => a -> m (ViewT m a)
single)

instance Monad m => MonadLogic (SeqT m) where
  {-# INLINE msplit #-}
  msplit :: forall a. SeqT m a -> SeqT m (Maybe (a, SeqT m a))
msplit (forall (m :: * -> *) a. Monad m => SeqT m a -> m (ViewT m a)
toViewT -> m (ViewT m a)
m) = forall (m :: * -> *) a. m (ViewT m a) -> SeqT m a
fromViewT forall a b. (a -> b) -> a -> b
$ do
    ViewT m a
r <- m (ViewT m a)
m
    case ViewT m a
r of
      ViewT m a
Empty -> forall (m :: * -> *) a. Monad m => a -> m (ViewT m a)
single forall a. Maybe a
Nothing
      a
a :< SeqT m a
t -> forall (m :: * -> *) a. Monad m => a -> m (ViewT m a)
single (forall a. a -> Maybe a
Just (a
a, SeqT m a
t))

  interleave :: forall a. SeqT m a -> SeqT m a -> SeqT m a
interleave SeqT m a
m1 SeqT m a
m2 = forall (m :: * -> *) a. m (ViewT m a) -> SeqT m a
fromViewT forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
Monad m =>
SeqT m a -> SeqT m a -> m (ViewT m a)
interleaveViewT SeqT m a
m1 SeqT m a
m2

  (forall (m :: * -> *) a. Monad m => SeqT m a -> m (ViewT m a)
toViewT -> m (ViewT m a)
m) >>- :: forall a b. SeqT m a -> (a -> SeqT m b) -> SeqT m b
>>- a -> SeqT m b
f = forall (m :: * -> *) a. m (ViewT m a) -> SeqT m a
fromViewT forall a b. (a -> b) -> a -> b
$ m (ViewT m a)
m forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall b a (m :: * -> *).
b -> (a -> SeqT m a -> b) -> ViewT m a -> b
viewT
     (forall (m :: * -> *) a. Monad m => a -> m a
return forall (m :: * -> *) a. ViewT m a
Empty) (\a
a SeqT m a
m' -> forall (m :: * -> *) a.
Monad m =>
SeqT m a -> SeqT m a -> m (ViewT m a)
interleaveViewT (a -> SeqT m b
f a
a) (SeqT m a
m' forall (m :: * -> *) a b. MonadLogic m => m a -> (a -> m b) -> m b
>>- a -> SeqT m b
f))

  ifte :: forall a b. SeqT m a -> (a -> SeqT m b) -> SeqT m b -> SeqT m b
ifte (forall (m :: * -> *) a. Monad m => SeqT m a -> m (ViewT m a)
toViewT -> m (ViewT m a)
t) a -> SeqT m b
th (forall (m :: * -> *) a. Monad m => SeqT m a -> m (ViewT m a)
toViewT -> m (ViewT m b)
el) = forall (m :: * -> *) a. m (ViewT m a) -> SeqT m a
fromViewT forall a b. (a -> b) -> a -> b
$ m (ViewT m a)
t forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall b a (m :: * -> *).
b -> (a -> SeqT m a -> b) -> ViewT m a -> b
viewT
    m (ViewT m b)
el
    (\a
a SeqT m a
s -> forall (m :: * -> *) a.
Monad m =>
m (ViewT m a) -> SeqT m a -> m (ViewT m a)
altViewT (forall (m :: * -> *) a. Monad m => SeqT m a -> m (ViewT m a)
toViewT (a -> SeqT m b
th a
a)) (SeqT m a
s forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= a -> SeqT m b
th))

  once :: forall a. SeqT m a -> SeqT m a
once (forall (m :: * -> *) a. Monad m => SeqT m a -> m (ViewT m a)
toViewT -> m (ViewT m a)
m) = forall (m :: * -> *) a. m (ViewT m a) -> SeqT m a
fromViewT forall a b. (a -> b) -> a -> b
$ m (ViewT m a)
m forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall b a (m :: * -> *).
b -> (a -> SeqT m a -> b) -> ViewT m a -> b
viewT
    (forall (m :: * -> *) a. Monad m => a -> m a
return forall (m :: * -> *) a. ViewT m a
Empty)
    (\a
a SeqT m a
_ -> forall (m :: * -> *) a. Monad m => a -> m (ViewT m a)
single a
a)

  lnot :: forall a. SeqT m a -> SeqT m ()
lnot (forall (m :: * -> *) a. Monad m => SeqT m a -> m (ViewT m a)
toViewT -> m (ViewT m a)
m) = forall (m :: * -> *) a. m (ViewT m a) -> SeqT m a
fromViewT forall a b. (a -> b) -> a -> b
$ m (ViewT m a)
m forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall b a (m :: * -> *).
b -> (a -> SeqT m a -> b) -> ViewT m a -> b
viewT
    (forall (m :: * -> *) a. Monad m => a -> m (ViewT m a)
single ()) (\ a
_ SeqT m a
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return forall (m :: * -> *) a. ViewT m a
Empty)

-- | A version of 'interleave' that produces a view instead of a
-- 'SeqT'. This lets us avoid @toViewT . fromViewT@ in '>>-'.
interleaveViewT :: Monad m => SeqT m a -> SeqT m a -> m (ViewT m a)
interleaveViewT :: forall (m :: * -> *) a.
Monad m =>
SeqT m a -> SeqT m a -> m (ViewT m a)
interleaveViewT (forall (m :: * -> *) a. Monad m => SeqT m a -> m (ViewT m a)
toViewT -> m (ViewT m a)
m1) SeqT m a
m2 = m (ViewT m a)
m1 forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall b a (m :: * -> *).
b -> (a -> SeqT m a -> b) -> ViewT m a -> b
viewT
  (forall (m :: * -> *) a. Monad m => SeqT m a -> m (ViewT m a)
toViewT SeqT m a
m2)
  (\a
a SeqT m a
m1' -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ a
a forall (m :: * -> *) a. a -> SeqT m a -> ViewT m a
:< forall (m :: * -> *) a. MonadLogic m => m a -> m a -> m a
interleave SeqT m a
m2 SeqT m a
m1')

-- | @choose = foldr (\a s -> pure a <|> s) empty@
--
-- @choose :: Monad m => [a] -> SeqT m a@
choose :: (F.Foldable t, Monad m) => t a -> SeqT m a
choose :: forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t a -> SeqT m a
choose = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
F.foldr forall (m :: * -> *) a. Monad m => a -> SeqT m a -> SeqT m a
cons forall (f :: * -> *) a. Alternative f => f a
empty
{-# INLINABLE choose #-}

-- | @chooseM = foldr (\ma s -> lift ma <|> s) empty@
--
-- @chooseM :: Monad m => [m a] -> SeqT m a@
chooseM :: (F.Foldable t, Monad m) => t (m a) -> SeqT m a
-- The idea here, which I hope is sensible, is to avoid building and
-- restructuring queues unnecessarily. We end up building only *singleton*
-- queues, which should hopefully be pretty cheap.
chooseM :: forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> SeqT m a
chooseM = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
F.foldr forall (m :: * -> *) a. Monad m => m a -> SeqT m a -> SeqT m a
consM forall (f :: * -> *) a. Alternative f => f a
empty
{-# INLINABLE chooseM #-}

-- | Perform all the actions in a 'SeqT' and gather the results.
observeAllT :: Monad m => SeqT m a -> m [a]
observeAllT :: forall (m :: * -> *) a. Monad m => SeqT m a -> m [a]
observeAllT (forall (m :: * -> *) a. Monad m => SeqT m a -> m (ViewT m a)
toViewT -> m (ViewT m a)
m) = m (ViewT m a)
m forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall {m :: * -> *} {a}. Monad m => ViewT m a -> m [a]
go where
  go :: ViewT m a -> m [a]
go (a
a :< SeqT m a
t) = forall (m :: * -> *) a b. Functor m => (a -> b) -> m a -> m b
myliftM (a
aforall a. a -> [a] -> [a]
:) (forall (m :: * -> *) a. Monad m => SeqT m a -> m (ViewT m a)
toViewT SeqT m a
t forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ViewT m a -> m [a]
go)
  go ViewT m a
_ = forall (m :: * -> *) a. Monad m => a -> m a
return []
{-# INLINEABLE observeAllT #-}

-- | Perform actions in a 'SeqT' until one of them produces a
-- result. Returns 'Nothing' if there are no results.
observeT :: Monad m => SeqT m a -> m (Maybe a)
observeT :: forall (m :: * -> *) a. Monad m => SeqT m a -> m (Maybe a)
observeT (forall (m :: * -> *) a. Monad m => SeqT m a -> m (ViewT m a)
toViewT -> m (ViewT m a)
m) = m (ViewT m a)
m forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall {m :: * -> *} {m :: * -> *} {a}.
Monad m =>
ViewT m a -> m (Maybe a)
go where
  go :: ViewT m a -> m (Maybe a)
go (a
a :< SeqT m a
_) = forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just a
a)
  go ViewT m a
Empty = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
{-# INLINE observeT #-}

-- | @observeManyT n s@ performs actions in @s@ until it produces
-- @n@ results or terminates. All the gathered results are returned.
observeManyT :: Monad m => Int -> SeqT m a -> m [a]
observeManyT :: forall (m :: * -> *) a. Monad m => Int -> SeqT m a -> m [a]
observeManyT Int
k SeqT m a
m = forall (m :: * -> *) a. Monad m => SeqT m a -> m (ViewT m a)
toViewT SeqT m a
m forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall {m :: * -> *} {a}. Monad m => Int -> ViewT m a -> m [a]
go Int
k where
  go :: Int -> ViewT m a -> m [a]
go Int
n ViewT m a
_ | Int
n forall a. Ord a => a -> a -> Bool
<= Int
0 = forall (m :: * -> *) a. Monad m => a -> m a
return []
  go Int
_ ViewT m a
Empty = forall (m :: * -> *) a. Monad m => a -> m a
return []
  go Int
n (a
a :< SeqT m a
t) = forall (m :: * -> *) a b. Functor m => (a -> b) -> m a -> m b
myliftM (a
aforall a. a -> [a] -> [a]
:) (forall (m :: * -> *) a. Monad m => Int -> SeqT m a -> m [a]
observeManyT (Int
nforall a. Num a => a -> a -> a
-Int
1) SeqT m a
t)
{-# INLINEABLE observeManyT #-}

-- | Get the first result in a 'Seq', if there is one.
observe :: Seq a -> Maybe a
observe :: forall a. Seq a -> Maybe a
observe = forall a. Identity a -> a
runIdentity forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. Monad m => SeqT m a -> m (Maybe a)
observeT
{-# INLINE observe #-}

-- | Get all the results in a 'Seq'.
observeAll :: Seq a -> [a]
observeAll :: forall a. Seq a -> [a]
observeAll = forall a. Identity a -> a
runIdentity forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. Monad m => SeqT m a -> m [a]
observeAllT
{-# INLINE observeAll #-}

-- | @observeMany n s@ gets up to @n@ results from a 'Seq'.
observeMany :: Int -> Seq a -> [a]
observeMany :: forall a. Int -> Seq a -> [a]
observeMany Int
n = forall a. Identity a -> a
runIdentity forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. Monad m => Int -> SeqT m a -> m [a]
observeManyT Int
n
{-# INLINE observeMany #-}

-- | Convert @'SeqT' m a@ to @t m a@ when @t@ is some other logic monad
-- transformer.
fromSeqT :: (Monad m, Monad (t m), MonadTrans t, Alternative (t m)) => SeqT m a -> t m a
fromSeqT :: forall (m :: * -> *) (t :: (* -> *) -> * -> *) a.
(Monad m, Monad (t m), MonadTrans t, Alternative (t m)) =>
SeqT m a -> t m a
fromSeqT (forall (m :: * -> *) a. Monad m => SeqT m a -> m (ViewT m a)
toViewT -> m (ViewT m a)
m) = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m (ViewT m a)
m forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ViewT m a
r -> case ViewT m a
r of
  ViewT m a
Empty -> forall (f :: * -> *) a. Alternative f => f a
empty
  a
a :< SeqT m a
s -> forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (m :: * -> *) (t :: (* -> *) -> * -> *) a.
(Monad m, Monad (t m), MonadTrans t, Alternative (t m)) =>
SeqT m a -> t m a
fromSeqT SeqT m a
s

-- | Convert @'SeqT' m a@ to @'L.LogicT' m a@.
--
-- @ toLogicT = 'fromSeqT' @
toLogicT :: Monad m => SeqT m a -> L.LogicT m a
toLogicT :: forall (m :: * -> *) a. Monad m => SeqT m a -> LogicT m a
toLogicT = forall (m :: * -> *) (t :: (* -> *) -> * -> *) a.
(Monad m, Monad (t m), MonadTrans t, Alternative (t m)) =>
SeqT m a -> t m a
fromSeqT

fromLogicT :: Monad m => L.LogicT m a -> SeqT m a
fromLogicT :: forall (m :: * -> *) a. Monad m => LogicT m a -> SeqT m a
fromLogicT (L.LogicT forall r. (a -> m r -> m r) -> m r -> m r
f) = forall (m :: * -> *) a. m (ViewT m a) -> SeqT m a
fromViewT forall a b. (a -> b) -> a -> b
$ forall r. (a -> m r -> m r) -> m r -> m r
f (\a
a m (ViewT m a)
v -> forall (m :: * -> *) a. Monad m => a -> m a
return (a
a forall (m :: * -> *) a. a -> SeqT m a -> ViewT m a
:< forall (m :: * -> *) a. m (ViewT m a) -> SeqT m a
fromViewT m (ViewT m a)
v)) (forall (m :: * -> *) a. Monad m => a -> m a
return forall (m :: * -> *) a. ViewT m a
Empty)

instance (Monad m, F.Foldable m) => F.Foldable (SeqT m) where
  foldMap :: forall m a. Monoid m => (a -> m) -> SeqT m a -> m
foldMap a -> m
f = forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
F.foldMap (forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
F.foldMap a -> m
f) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. Monad m => SeqT m a -> m (ViewT m a)
toViewT

instance (Monad m, T.Traversable m) => T.Traversable (SeqT m) where
  -- Why is this lawful? It comes down to the fact that toViewT and
  -- fromViewT are inverses, modulo representation and detailed
  -- strictness. They witness a sort of stepwise isomorphism between
  -- SeqT and the obviously traversable
  --
  --   newtype ML m a = ML (m (ViewT m a))
  --
  -- Why can't we just use the derived Traversable instance? It doesn't
  -- respect ==. See https://github.com/dagit/logict-sequence/issues/51#issuecomment-896242724
  -- for an example.
  traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> SeqT m a -> f (SeqT m b)
traverse a -> f b
f = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (m :: * -> *) a. m (ViewT m a) -> SeqT m a
fromViewT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
T.traverse (forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
T.traverse a -> f b
f) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. Monad m => SeqT m a -> m (ViewT m a)
toViewT

-- | 'hoist' is 'hoistPre'.
instance MFunctor SeqT where
  -- Note: if `f` is not a monad morphism, then hoist may not respect
  -- (==). That is, it could be that
  --
  --   s == t = True
  --
  --  but
  --
  --   hoist f s == hoist f t = False..
  --
  -- This behavior is permitted by the MFunctor
  -- documentation, and allows us to avoid restructuring
  -- the SeqT.
  hoist :: forall (m :: * -> *) (n :: * -> *) b.
Monad m =>
(forall a. m a -> n a) -> SeqT m b -> SeqT n b
hoist forall a. m a -> n a
f = forall (m :: * -> *) (n :: * -> *) b.
Monad m =>
(forall a. m a -> n a) -> SeqT m b -> SeqT n b
hoistPre forall a. m a -> n a
f

-- | This function is the implementation of 'hoist' for 'SeqT'. The passed
-- function is required to be a monad morphism.
hoistPre :: Monad m => (forall x. m x -> n x) -> SeqT m a -> SeqT n a
hoistPre :: forall (m :: * -> *) (n :: * -> *) b.
Monad m =>
(forall a. m a -> n a) -> SeqT m b -> SeqT n b
hoistPre forall x. m x -> n x
f (SeqT Queue (m (ViewT m a))
s) = forall (m :: * -> *) a. Queue (m (ViewT m a)) -> SeqT m a
SeqT forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall x. m x -> n x
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a b. Functor m => (a -> b) -> m a -> m b
myliftM ViewT m a -> ViewT n a
go) Queue (m (ViewT m a))
s
  where
    go :: ViewT m a -> ViewT n a
go ViewT m a
Empty = forall (m :: * -> *) a. ViewT m a
Empty
    go (a
a :< SeqT m a
as) = a
a forall (m :: * -> *) a. a -> SeqT m a -> ViewT m a
:< forall (m :: * -> *) (n :: * -> *) b.
Monad m =>
(forall a. m a -> n a) -> SeqT m b -> SeqT n b
hoistPre forall x. m x -> n x
f SeqT m a
as

-- | A version of `hoist` that uses the `Monad` instance for @n@
-- rather than for @m@. Like @hoist@, the passed function is required
-- to be a monad morphism.
hoistPost :: Monad n => (forall x. m x -> n x) -> SeqT m a -> SeqT n a
hoistPost :: forall (n :: * -> *) (m :: * -> *) a.
Monad n =>
(forall x. m x -> n x) -> SeqT m a -> SeqT n a
hoistPost forall x. m x -> n x
f (SeqT Queue (m (ViewT m a))
s) = forall (m :: * -> *) a. Queue (m (ViewT m a)) -> SeqT m a
SeqT forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (m :: * -> *) a b. Functor m => (a -> b) -> m a -> m b
myliftM ViewT m a -> ViewT n a
go forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall x. m x -> n x
f) Queue (m (ViewT m a))
s
  where
      go :: ViewT m a -> ViewT n a
go ViewT m a
Empty = forall (m :: * -> *) a. ViewT m a
Empty
      go (a
a :< SeqT m a
as) = a
a forall (m :: * -> *) a. a -> SeqT m a -> ViewT m a
:< forall (n :: * -> *) (m :: * -> *) a.
Monad n =>
(forall x. m x -> n x) -> SeqT m a -> SeqT n a
hoistPost forall x. m x -> n x
f SeqT m a
as

-- | A version of 'hoist' that works for arbitrary functions, rather
-- than just monad morphisms.
hoistPreUnexposed :: forall m n a. Monad m => (forall x. m x -> n x) -> SeqT m a -> SeqT n a
hoistPreUnexposed :: forall (m :: * -> *) (n :: * -> *) b.
Monad m =>
(forall a. m a -> n a) -> SeqT m b -> SeqT n b
hoistPreUnexposed forall x. m x -> n x
f (forall (m :: * -> *) a. Monad m => SeqT m a -> m (ViewT m a)
toViewT -> m (ViewT m a)
m) = forall (m :: * -> *) a. m (ViewT m a) -> SeqT m a
fromViewT forall a b. (a -> b) -> a -> b
$ forall x. m x -> n x
f (forall (m :: * -> *) a b. Functor m => (a -> b) -> m a -> m b
myliftM ViewT m a -> ViewT n a
go m (ViewT m a)
m)
  where
      go :: ViewT m a -> ViewT n a
go ViewT m a
Empty = forall (m :: * -> *) a. ViewT m a
Empty
      go (a
a :< SeqT m a
as) = a
a forall (m :: * -> *) a. a -> SeqT m a -> ViewT m a
:< forall (m :: * -> *) (n :: * -> *) b.
Monad m =>
(forall a. m a -> n a) -> SeqT m b -> SeqT n b
hoistPreUnexposed forall x. m x -> n x
f SeqT m a
as

-- | A version of 'hoistPost' that works for arbitrary functions, rather
-- than just monad morphisms. This should be preferred when the `Monad` instance
-- for `n` is less expensive than that for `m`.
hoistPostUnexposed :: forall m n a. (Monad m, Monad n) => (forall x. m x -> n x) -> SeqT m a -> SeqT n a
hoistPostUnexposed :: forall (m :: * -> *) (n :: * -> *) a.
(Monad m, Monad n) =>
(forall x. m x -> n x) -> SeqT m a -> SeqT n a
hoistPostUnexposed forall x. m x -> n x
f (forall (m :: * -> *) a. Monad m => SeqT m a -> m (ViewT m a)
toViewT -> m (ViewT m a)
m) = forall (m :: * -> *) a. m (ViewT m a) -> SeqT m a
fromViewT forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a b. Functor m => (a -> b) -> m a -> m b
myliftM ViewT m a -> ViewT n a
go (forall x. m x -> n x
f m (ViewT m a)
m)
  where
      go :: ViewT m a -> ViewT n a
go ViewT m a
Empty = forall (m :: * -> *) a. ViewT m a
Empty
      go (a
a :< SeqT m a
as) = a
a forall (m :: * -> *) a. a -> SeqT m a -> ViewT m a
:< forall (m :: * -> *) (n :: * -> *) a.
(Monad m, Monad n) =>
(forall x. m x -> n x) -> SeqT m a -> SeqT n a
hoistPostUnexposed forall x. m x -> n x
f SeqT m a
as

instance MonadIO m => MonadIO (SeqT m) where
  {-# INLINE liftIO #-}
  liftIO :: forall a. IO a -> SeqT m a
liftIO = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO

instance MonadReader e m => MonadReader e (SeqT m) where
  -- TODO: write more thorough tests for this instance (issue #31)
  ask :: SeqT m e
ask = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall r (m :: * -> *). MonadReader r m => m r
ask
  local :: forall a. (e -> e) -> SeqT m a -> SeqT m a
local e -> e
f (SeqT Queue (m (ViewT m a))
q) = forall (m :: * -> *) a. Queue (m (ViewT m a)) -> SeqT m a
SeqT forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local e -> e
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a b. Functor m => (a -> b) -> m a -> m b
myliftM ViewT m a -> ViewT m a
go) Queue (m (ViewT m a))
q
    where
      go :: ViewT m a -> ViewT m a
go ViewT m a
Empty = forall (m :: * -> *) a. ViewT m a
Empty
      go (a
a :< SeqT m a
s) = a
a forall (m :: * -> *) a. a -> SeqT m a -> ViewT m a
:< forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local e -> e
f SeqT m a
s

instance MonadState s m => MonadState s (SeqT m) where
  get :: SeqT m s
get = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall s (m :: * -> *). MonadState s m => m s
get
  put :: s -> SeqT m ()
put = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s (m :: * -> *). MonadState s m => s -> m ()
put
  state :: forall a. (s -> (a, s)) -> SeqT m a
state = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s (m :: * -> *) a. MonadState s m => (s -> (a, s)) -> m a
state

instance MonadError e m => MonadError e (SeqT m) where
  -- TODO: write tests for this instance (issue #31)
  throwError :: forall a. e -> SeqT m a
throwError = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError
  catchError :: forall a. SeqT m a -> (e -> SeqT m a) -> SeqT m a
catchError (forall (m :: * -> *) a. Monad m => SeqT m a -> m (ViewT m a)
toViewT -> m (ViewT m a)
m) e -> SeqT m a
h = forall (m :: * -> *) a. m (ViewT m a) -> SeqT m a
fromViewT forall a b. (a -> b) -> a -> b
$ (forall (m :: * -> *) a b. Functor m => (a -> b) -> m a -> m b
myliftM ViewT m a -> ViewT m a
go m (ViewT m a)
m) forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
`catchError` (forall (m :: * -> *) a. Monad m => SeqT m a -> m (ViewT m a)
toViewT forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> SeqT m a
h)
    where
      go :: ViewT m a -> ViewT m a
go ViewT m a
Empty = forall (m :: * -> *) a. ViewT m a
Empty
      go (a
a :< SeqT m a
s) = a
a forall (m :: * -> *) a. a -> SeqT m a -> ViewT m a
:< forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
catchError SeqT m a
s e -> SeqT m a
h

#if MIN_VERSION_base(4,8,0)
instance MonadZip m => MonadZip (SeqT m) where
  mzipWith :: forall a b c. (a -> b -> c) -> SeqT m a -> SeqT m b -> SeqT m c
mzipWith a -> b -> c
f (forall (m :: * -> *) a. Monad m => SeqT m a -> m (ViewT m a)
toViewT -> m (ViewT m a)
m) (forall (m :: * -> *) a. Monad m => SeqT m a -> m (ViewT m a)
toViewT -> m (ViewT m b)
n) = forall (m :: * -> *) a. m (ViewT m a) -> SeqT m a
fromViewT forall a b. (a -> b) -> a -> b
$
    forall (m :: * -> *) a b c.
MonadZip m =>
(a -> b -> c) -> m a -> m b -> m c
mzipWith ViewT m a -> ViewT m b -> ViewT m c
go m (ViewT m a)
m m (ViewT m b)
n
    where
      go :: ViewT m a -> ViewT m b -> ViewT m c
go (a
a :< SeqT m a
as) (b
b :< SeqT m b
bs) = a -> b -> c
f a
a b
b forall (m :: * -> *) a. a -> SeqT m a -> ViewT m a
:< forall (m :: * -> *) a b c.
MonadZip m =>
(a -> b -> c) -> m a -> m b -> m c
mzipWith a -> b -> c
f SeqT m a
as SeqT m b
bs
      go ViewT m a
_ ViewT m b
_ = forall (m :: * -> *) a. ViewT m a
Empty

  munzip :: forall a b. SeqT m (a, b) -> (SeqT m a, SeqT m b)
munzip (forall (m :: * -> *) a. Monad m => SeqT m a -> m (ViewT m a)
toViewT -> m (ViewT m (a, b))
m)
    | (m (ViewT m a)
l, m (ViewT m b)
r) <- forall (m :: * -> *) a b. MonadZip m => m (a, b) -> (m a, m b)
munzip (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall {m :: * -> *} {a} {a}.
MonadZip m =>
ViewT m (a, a) -> (ViewT m a, ViewT m a)
go m (ViewT m (a, b))
m) = (forall (m :: * -> *) a. m (ViewT m a) -> SeqT m a
fromViewT m (ViewT m a)
l, forall (m :: * -> *) a. m (ViewT m a) -> SeqT m a
fromViewT m (ViewT m b)
r)
    where
      go :: ViewT m (a, a) -> (ViewT m a, ViewT m a)
go ViewT m (a, a)
Empty = (forall (m :: * -> *) a. ViewT m a
Empty, forall (m :: * -> *) a. ViewT m a
Empty)
      go ((a
a, a
b) :< SeqT m (a, a)
asbs) = (a
a forall (m :: * -> *) a. a -> SeqT m a -> ViewT m a
:< SeqT m a
as, a
b forall (m :: * -> *) a. a -> SeqT m a -> ViewT m a
:< SeqT m a
bs)
        where
          -- We want to be lazy so we don't force the entire
          -- structure unnecessarily. But we don't want to introduce
          -- a space leak, so we're careful to create selector thunks
          -- to deconstruct the rest of the chain.
          {-# NOINLINE muabs #-}
          {-# NOINLINE as #-}
          {-# NOINLINE bs #-}
          muabs :: (SeqT m a, SeqT m a)
muabs = forall (m :: * -> *) a b. MonadZip m => m (a, b) -> (m a, m b)
munzip SeqT m (a, a)
asbs
          (SeqT m a
as, SeqT m a
bs) = (SeqT m a, SeqT m a)
muabs
#endif

#if MIN_VERSION_base(4,8,0)
myliftM :: Functor m => (a -> b) -> m a -> m b
myliftM :: forall (m :: * -> *) a b. Functor m => (a -> b) -> m a -> m b
myliftM = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
#else
myliftM :: Monad m => (a -> b) -> m a -> m b
myliftM = Monad.liftM
#endif
{-# INLINE myliftM #-}