diff --git a/constrained-monads.cabal b/constrained-monads.cabal
--- a/constrained-monads.cabal
+++ b/constrained-monads.cabal
@@ -1,5 +1,5 @@
 name:                constrained-monads
-version:             0.3.0.0
+version:             0.4.0.0
 synopsis:            Typeclasses and instances for monads with constraints. 
 description:         A library for monads with constraints over the types they contain. This allows set, etc to conform to the monad class. It is structured as a prelude replacement: everything that doesn't conflict with the new definitions of 'Functor', 'Monad', etc is reexported.
                      
@@ -24,6 +24,7 @@
                      , Control.Monad.Constrained.IO
                      , Control.Monad.Constrained.Cont
                      , Control.Monad.Constrained.IntSet
+                     , Control.Monad.Constrained.Ap
   build-depends:       base >= 4.9 && < 5
                      , containers >= 0.5
                      , transformers >= 0.5
diff --git a/src/Control/Monad/Constrained.hs b/src/Control/Monad/Constrained.hs
--- a/src/Control/Monad/Constrained.hs
+++ b/src/Control/Monad/Constrained.hs
@@ -23,11 +23,13 @@
   ,Monad(..)
   ,Alternative(..)
   ,Traversable(..)
+  ,MonadFail(..)
   ,
    -- * Horrible type-level stuff
-  Free(..)
+  Ap(..)
   ,lowerP
   ,lowerM
+  ,liftAp
   ,
    -- * Useful functions
    guard
@@ -46,10 +48,10 @@
   ,void
   ,forever
   ,for_
+  ,join
   ,
    -- * Syntax
    ifThenElse
-  ,fail
   ,(>>)
   ,return
   ,module RestPrelude)
@@ -93,20 +95,22 @@
 
 -- | A free applicative. Applicative operations are defined in terms of
 -- /interpretations/ of this.
-infixl 5 :>
-data Free f a where
-  Pure :: a -> Free f a
-  (:>) :: Free f (a -> b) -> f a -> Free f b
+data Ap f a where
+  Pure :: a -> Ap f a
+  Ap :: Ap f (a -> b) -> f a -> Ap f b
 
-instance Prelude.Functor (Free f) where
+instance Prelude.Functor (Ap f) where
   fmap f (Pure a) = Pure (f a)
-  fmap f (x :> y) = ((f .) Prelude.<$> x) :> y
+  fmap f (Ap x y) = Ap ((f .) Prelude.<$> x) y
 
-instance Prelude.Applicative (Free f) where
+instance Prelude.Applicative (Ap f) where
   pure = Pure
   Pure f <*> y = Prelude.fmap f y
-  (x :> y) <*> z = (flip Prelude.<$> x Prelude.<*> z) :> y
+  Ap x y <*> z = Ap (flip Prelude.<$> x Prelude.<*> z) y
 
+liftAp :: f a -> Ap f a
+liftAp = Ap (Pure id)
+
 --------------------------------------------------------------------------------
 -- Standard classes
 --------------------------------------------------------------------------------
@@ -291,39 +295,40 @@
     -- in terms of @('>>=')@, which is what 'lowerM' does.
     lower
         :: Suitable f a
-        => Free f a -> f a
+        => Ap f a -> f a
 
     liftA2
         :: Suitable f c
         => (a -> b -> c) -> f a -> f b -> f c
     liftA2 f xs ys =
-        lower (Pure f :> xs :> ys)
+        lower (Ap (Ap (Pure f) xs) ys)
 
     liftA3
         :: Suitable f d
         => (a -> b -> c -> d) -> f a -> f b -> f c -> f d
     liftA3 f xs ys zs =
-        lower (Pure f :> xs :> ys :> zs)
+        lower (Ap (Ap (Ap (Pure f) xs) ys) zs)
 
     {-# INLINE liftA2 #-}
     {-# INLINE liftA3 #-}
 
+infixl 4 <**>
 -- | A variant of '<*>' with the arguments reversed.
 (<**>) :: (Applicative f, Suitable f b) => f a -> f (a -> b) -> f b
 (<**>) = liftA2 (flip ($))
 
 -- | A definition of 'lower' that uses monadic operations.
-lowerM :: (Monad f, Suitable f a) => Free f a -> f a
+lowerM :: (Monad f, Suitable f a) => Ap f a -> f a
 lowerM = go pure where
-  go :: (Suitable f b, Monad f) => (a -> f b) -> Free f a -> f b
+  go :: (Suitable f b, Monad f) => (a -> f b) -> Ap f a -> f b
   go f (Pure x) = f x
-  go f (xs :> x) = go (\c -> x >>= f . c) xs
+  go f (Ap xs x) = go (\c -> x >>= f . c) xs
 
 -- | A definition of 'lower' which uses the "Prelude"'s @('Prelude.<*>')@.
-lowerP :: Prelude.Applicative f => Free f a -> f a
+lowerP :: Prelude.Applicative f => Ap f a -> f a
 lowerP (Pure x) = Prelude.pure x
-lowerP (Pure f :> xs) = Prelude.fmap f xs
-lowerP (ys :> xs) = lowerP ys Prelude.<*> xs
+lowerP (Ap (Pure f) xs) = Prelude.fmap f xs
+lowerP (Ap ys xs) = lowerP ys Prelude.<*> xs
 {-# INLINABLE lowerP #-}
 
 {-# INLINE liftA2P #-}
@@ -375,6 +380,14 @@
     (>>=)
         :: Suitable f b
         => f a -> (a -> f b) -> f b
+
+-- | See
+-- <https://hackage.haskell.org/package/base-4.9.1.0/docs/Control-Monad-Fail.html here>
+-- for more details.
+class Monad f => MonadFail f where
+  -- | Called when a pattern match fails in do-notation.
+  fail :: Suitable f a => String -> f a
+
 -- | A monoid on applicative functors.
 --
 -- If defined, 'some' and 'many' should be the least solutions
@@ -684,6 +697,10 @@
 void :: (Functor f, Suitable f ()) => f a -> f ()
 void = (<$) ()
 
+-- | Collapse one monadic layer.
+join :: (Monad f, Suitable f a) => f (f a) -> f a
+join x = x >>= id
+
 --------------------------------------------------------------------------------
 -- syntax
 --------------------------------------------------------------------------------
@@ -693,10 +710,7 @@
 ifThenElse True t _ = t
 ifThenElse False _ f = f
 
--- | Called on a failed pattern match in a monadic bind. To be avoided.
-fail :: String -> a
-fail = error
-
+infixl 1 >>
 -- | Sequence two actions, discarding the result of the first. Alias for
 -- @('*>')@.
 (>>)
@@ -733,10 +747,13 @@
   (<|>) = (++)
 
 instance Monad [] where
-  (>>=) = (Prelude.>>=)
+    (>>=) = (Prelude.>>=)
 
+instance MonadFail [] where
+    fail _ = []
+
 instance Traversable [] where
-  traverse f = foldr (liftA2 (:) . f) (pure [])
+    traverse f = foldr (liftA2 (:) . f) (pure [])
 
 instance Functor Maybe where
     type Suitable Maybe a = ()
@@ -759,6 +776,9 @@
 instance Monad Maybe where
     (>>=) = (Prelude.>>=)
 
+instance MonadFail Maybe where
+    fail _ = Nothing
+
 instance Traversable Maybe where
     traverse _ Nothing = pure Nothing
     traverse f (Just x) = fmap Just (f x)
@@ -784,6 +804,9 @@
 instance Monad IO where
     (>>=) = (Prelude.>>=)
 
+instance MonadFail IO where
+    fail = Prelude.fail
+
 instance Functor Identity where
     type Suitable Identity a = ()
     fmap = Prelude.fmap
@@ -821,8 +844,12 @@
 instance Monad (Either a) where
     (>>=) = (Prelude.>>=)
 
+instance IsString a =>
+         MonadFail (Either a) where
+    fail = Left . fromString
+
 instance Traversable (Either a) where
-  traverse f = either (pure . Left) (fmap Right . f)
+    traverse f = either (pure . Left) (fmap Right . f)
 
 instance Functor Set where
     type Suitable Set a = Ord a
@@ -839,6 +866,9 @@
 instance Monad Set where
     (>>=) = flip foldMap
 
+instance MonadFail Set where
+    fail _ = Set.empty
+
 instance Alternative Set where
     empty = Set.empty
     (<|>) = Set.union
@@ -894,6 +924,9 @@
 instance Monad Seq where
     (>>=) = (Prelude.>>=)
 
+instance MonadFail Seq where
+    fail _ = empty
+
 instance Functor Tree where
     type Suitable Tree a = ()
     fmap = Prelude.fmap
@@ -1061,9 +1094,9 @@
     f <*> v = ReaderT $ \ r -> runReaderT f r <*> runReaderT v r
     {-# INLINE (<*>) #-}
     lower ys = ReaderT $ \r -> lower (tr r ys) where
-      tr :: r -> Free (ReaderT r m) xs -> Free m xs
+      tr :: r -> Ap (ReaderT r m) xs -> Ap m xs
       tr _ (Pure x) = Pure x
-      tr r (xs :> x) = tr r xs :> runReaderT x r
+      tr r (Ap xs x) = Ap (tr r xs) (runReaderT x r)
     ReaderT xs *> ReaderT ys = ReaderT (\c -> xs c *> ys c)
     ReaderT xs <* ReaderT ys = ReaderT (\c -> xs c <* ys c)
 
@@ -1073,6 +1106,10 @@
     m <|> n = ReaderT $ \ r -> runReaderT m r <|> runReaderT n r
     {-# INLINE (<|>) #-}
 
+instance MonadFail m =>
+         MonadFail (ReaderT r m) where
+    fail = ReaderT . const . fail
+
 instance (Monad m) => Monad (ReaderT r m) where
     m >>= k  = ReaderT $ \ r -> do
         a <- runReaderT m r
@@ -1083,22 +1120,29 @@
 liftReaderT m = ReaderT (const m)
 {-# INLINE liftReaderT #-}
 
-instance Functor m => Functor (MaybeT m) where
-  type Suitable (MaybeT m) a = (Suitable m (Maybe a), Suitable m a)
-  fmap f (MaybeT xs) = MaybeT ((fmap.fmap) f xs)
-  x <$ MaybeT xs = MaybeT (fmap (x<$) xs)
+instance Functor m =>
+         Functor (MaybeT m) where
+    type Suitable (MaybeT m) a = (Suitable m (Maybe a), Suitable m a)
+    fmap f (MaybeT xs) = MaybeT ((fmap . fmap) f xs)
+    x <$ MaybeT xs = MaybeT (fmap (x <$) xs)
 
-instance Monad m => Applicative (MaybeT m) where
-  pure x = MaybeT (pure (Just x))
-  MaybeT fs <*> MaybeT xs = MaybeT (liftA2 (<*>) fs xs)
-  lower = lowerM
-  MaybeT xs *> MaybeT ys = MaybeT (liftA2 (*>) xs ys)
-  MaybeT xs <* MaybeT ys = MaybeT (liftA2 (<*) xs ys)
+instance Monad m =>
+         Applicative (MaybeT m) where
+    pure x = MaybeT (pure (Just x))
+    MaybeT fs <*> MaybeT xs = MaybeT (liftA2 (<*>) fs xs)
+    lower = lowerM
+    MaybeT xs *> MaybeT ys = MaybeT (liftA2 (*>) xs ys)
+    MaybeT xs <* MaybeT ys = MaybeT (liftA2 (<*) xs ys)
 
-instance Monad m => Monad (MaybeT m) where
-  MaybeT x >>= f = MaybeT (x >>= maybe (pure Nothing) (runMaybeT . f))
+instance Monad m =>
+         Monad (MaybeT m) where
+    MaybeT x >>= f = MaybeT (x >>= maybe (pure Nothing) (runMaybeT . f))
 
 instance Monad m =>
+         MonadFail (MaybeT m) where
+    fail _ = empty
+
+instance Monad m =>
          Alternative (MaybeT m) where
     empty = MaybeT (pure Nothing)
     MaybeT x <|> MaybeT y = MaybeT (x >>= maybe y (pure . Just))
@@ -1117,6 +1161,9 @@
     ExceptT xs *> ExceptT ys = ExceptT (xs *> ys)
     ExceptT xs <* ExceptT ys = ExceptT (xs <* ys)
 
+instance (Monad m, IsString e) => MonadFail (ExceptT e m) where
+    fail = ExceptT . pure . Left . fromString
+
 instance Monad m => Monad (ExceptT e m) where
   ExceptT xs >>= f = ExceptT (xs >>= either (pure . Left) (runExceptT . f))
 
@@ -1141,7 +1188,7 @@
         (coerce :: (f (a -> b) -> f a -> f b) -> IdentityT f (a -> b) -> IdentityT f a -> IdentityT f b)
             (<*>)
     lower =
-        (coerce :: (Free f xs -> f b) -> (Free (IdentityT f) xs -> IdentityT f b))
+        (coerce :: (Ap f xs -> f b) -> (Ap (IdentityT f) xs -> IdentityT f b))
             lower
     IdentityT xs *> IdentityT ys = IdentityT (xs *> ys)
     IdentityT xs <* IdentityT ys = IdentityT (xs <* ys)
@@ -1151,3 +1198,7 @@
     (>>=) =
         (coerce :: (f a -> (a -> f b) -> f b) -> IdentityT f a -> (a -> IdentityT f b) -> IdentityT f b)
             (>>=)
+
+instance MonadFail m =>
+         MonadFail (IdentityT m) where
+    fail = IdentityT . fail
diff --git a/src/Control/Monad/Constrained/Ap.hs b/src/Control/Monad/Constrained/Ap.hs
new file mode 100644
--- /dev/null
+++ b/src/Control/Monad/Constrained/Ap.hs
@@ -0,0 +1,234 @@
+{-# LANGUAGE ConstraintKinds  #-}
+{-# LANGUAGE RankNTypes       #-}
+{-# LANGUAGE RebindableSyntax #-}
+{-# LANGUAGE TypeFamilies     #-}
+
+-- | This module allows the use of the Applicative Do extension with
+-- constrained monads.
+module Control.Monad.Constrained.Ap
+  (Monad(..)
+  ,MonadFail(..)
+  ,return
+  ,ifThenElse
+  ,(>>))
+  where
+
+import           Control.Monad.Constrained        (Ap (..), liftAp, lower)
+import qualified Control.Monad.Constrained        as Constrained
+
+import           GHC.Exts
+
+import qualified Control.Monad
+import           Prelude                          hiding (Monad (..))
+import qualified Prelude
+
+import           Control.Monad.Trans.Cont         (ContT)
+import           Control.Monad.Trans.Except       (ExceptT(..))
+import           Control.Monad.Trans.Identity     (IdentityT (..))
+import           Control.Monad.Trans.Maybe        (MaybeT(..))
+import           Control.Monad.Trans.Reader       (ReaderT (..))
+import           Control.Monad.Trans.State        (StateT)
+import qualified Control.Monad.Trans.State.Strict as Strict (StateT)
+import           Data.Functor.Identity            (Identity)
+import           Data.Sequence                    (Seq)
+
+-- | This class is for types which have no constraints on their applicative
+-- operations, but /do/ have constraints on the monadic operations.
+--
+-- Most types which can conform are just standard unconstrained monads, with
+-- the exception of the free applicative. The type @'Ap' f a@ is an applicative
+-- for /any/ @f@. However, it can only be made a monad by interpreting the
+-- underlying type (which may be constrained), running the monadic operation,
+-- and then lifting the result. In practice, this allows you to write code on
+-- on the @Ap@ type, using applicative do notation, and have it be interpreted
+-- correctly.
+--
+-- For instance, take the following expression:
+--
+-- @example = do
+--   x <- pure 1
+--   y <- pure 2
+--   pure (x + y)@
+--
+-- With the standard constrained monad module, you can instantiate that at
+-- any type which is a constrained monad. 'Data.Set.Set', for instance. However,
+-- if @-XApplicativeDo@ is turned on, you will get the error:
+--
+-- @No instance for ('Ord' ('Integer' -> 'Data.Set.Set' 'Integer'))@
+--
+-- The solution is to use @'Ap' 'Data.Set.Set'@ instead, which has the same
+-- constraints on expressions built with '<*>' as those built with '>>='.
+class Applicative f =>
+      Monad f  where
+    type Suitable f a :: Constraint
+    infixl 1 >>=
+    (>>=)
+        :: (Suitable f a, Suitable f b)
+        => f a -> (a -> f b) -> f b
+    join
+        :: Suitable f a
+        => f (f a) -> f a
+
+-- | See
+-- <https://hackage.haskell.org/package/base-4.9.1.0/docs/Control-Monad-Fail.html here>
+-- for more details.
+class Monad f => MonadFail f where
+  -- | Called when a pattern match fails in do-notation.
+  fail :: Suitable f a => String -> f a
+
+instance Constrained.Monad f =>
+         Monad (Ap f) where
+    type Suitable (Ap f) a = Constrained.Suitable f a
+    (>>=) ap f = liftAp (lower ap Constrained.>>= (lower . f))
+    join = liftAp . go id . fmap lower
+      where
+        go
+            :: forall a f b.
+               (Constrained.Suitable f b, Constrained.Monad f)
+            => (a -> f b) -> Ap f a -> f b
+        go c (Pure x) = c x
+        go f (Ap xs x) =
+            go
+                (\c ->
+                      x Constrained.>>= (f . c))
+                xs
+-- | An alias for 'pure'
+return :: Applicative f => a -> f a
+return = pure
+
+-- | Function to which the @if ... then ... else@ syntax desugars to
+ifThenElse :: Bool -> a -> a -> a
+ifThenElse True t _ = t
+ifThenElse False _ f = f
+
+infixl 1 >>
+-- | Sequence two actions, discarding the result of the first. Alias for
+-- @('*>')@.
+(>>)
+    :: Applicative f
+    => f a -> f b -> f b
+(>>) = (*>)
+
+instance Monad [] where
+    type Suitable [] a = ()
+    (>>=) = (Prelude.>>=)
+    join = Control.Monad.join
+
+instance MonadFail [] where
+    fail _ = []
+
+instance Monad Maybe where
+    type Suitable Maybe a = ()
+    (>>=) = (Prelude.>>=)
+    join = Control.Monad.join
+
+instance MonadFail Maybe where
+    fail _ = Nothing
+
+instance Monad IO where
+    type Suitable IO a = ()
+    (>>=) = (Prelude.>>=)
+    join = Control.Monad.join
+
+instance MonadFail IO where
+    fail = Prelude.fail
+
+instance Monad Identity where
+    type Suitable Identity a = ()
+    (>>=) = (Prelude.>>=)
+    join = Control.Monad.join
+
+instance Monad (Either e) where
+    type Suitable (Either e) a = ()
+    (>>=) = (Prelude.>>=)
+    join = Control.Monad.join
+
+instance IsString a =>
+         MonadFail (Either a) where
+    fail = Left . fromString
+
+instance Monoid m =>
+         Monad ((,) m) where
+    type Suitable ((,) m) a = ()
+    (>>=) = (Prelude.>>=)
+    join = Control.Monad.join
+
+instance Monad Seq where
+    type Suitable Seq a = ()
+    (>>=) = (Prelude.>>=)
+    join = Control.Monad.join
+
+instance MonadFail Seq where
+    fail _ = Constrained.empty
+
+instance Monad ((->) b) where
+    type Suitable ((->) b) a = ()
+    (>>=) = (Prelude.>>=)
+    join = Control.Monad.join
+
+instance Monad (ContT r m) where
+    type Suitable (ContT r m) a = ()
+    (>>=) = (Prelude.>>=)
+    join = Control.Monad.join
+
+instance Prelude.Monad m =>
+         Monad (Strict.StateT s m) where
+    type Suitable (Strict.StateT s m) a = ()
+    (>>=) = (Prelude.>>=)
+    join = Control.Monad.join
+
+instance Prelude.Monad m =>
+         Monad (StateT s m) where
+    type Suitable (StateT s m) a = ()
+    (>>=) = (Prelude.>>=)
+    join = Control.Monad.join
+
+instance Monad m =>
+         Monad (ReaderT s m) where
+    type Suitable (ReaderT s m) a = Suitable m a
+    m >>= k =
+        ReaderT $
+        \r -> do
+            a <- runReaderT m r
+            runReaderT (k a) r
+    {-# INLINE (>>=) #-}
+    join (ReaderT x) =
+        ReaderT
+            (\r ->
+                  join (flip runReaderT r <$> x r))
+    {-# INLINE join #-}
+
+instance MonadFail m =>
+         MonadFail (ReaderT r m) where
+    fail = ReaderT . const . fail
+
+instance Prelude.Monad m =>
+         Monad (MaybeT m) where
+    type Suitable (MaybeT m) a = ()
+    (>>=) = (Prelude.>>=)
+    join = Control.Monad.join
+
+instance Prelude.Monad m =>
+         MonadFail (MaybeT m) where
+    fail _ = Control.Monad.mzero
+
+instance Prelude.Monad m =>
+         Monad (ExceptT e m) where
+    type Suitable (ExceptT e m) a = ()
+    (>>=) = (Prelude.>>=)
+    join = Control.Monad.join
+
+instance (Prelude.Monad m, IsString e) => MonadFail (ExceptT e m) where
+    fail = ExceptT . pure . Left . fromString
+
+instance Monad m =>
+         Monad (IdentityT m) where
+    type Suitable (IdentityT m) a = Suitable m a
+    (>>=) =
+        (coerce :: (f a -> (a -> f b) -> f b) -> IdentityT f a -> (a -> IdentityT f b) -> IdentityT f b)
+            (>>=)
+    join (IdentityT x) = IdentityT (join (fmap runIdentityT x))
+
+instance MonadFail m =>
+         MonadFail (IdentityT m) where
+    fail = IdentityT . fail