Merge pull request #329 from turion/dev_mtl_transformers

Bump mtl -> 2.3, transformers -> 0.6

monad-bayes.cabal

@@ -53,7 +53,7 @@ common deps
     , matrix           ^>=0.3
     , monad-coroutine  ^>=0.9.0
     , monad-extras     ^>=0.6
-    , mtl              ^>=2.2.2
+    , mtl              >=2.2     && <2.4
     , mwc-random       >=0.13.6  && <0.16
     , pipes            ^>=4.3
     , pretty-simple    ^>=4.1
@@ -63,21 +63,21 @@ common deps
     , scientific       ^>=0.3
     , statistics       >=0.14.0  && <0.17
     , text             >=1.2     && <2.1
+    , transformers     >=0.5.6   && <0.7
     , vector           >=0.12.0  && <0.14
     , vty              ^>=5.38
 
 common test-deps
   build-depends:
     , abstract-par          ^>=0.3
-    , criterion             >=1.5    && <1.7
+    , criterion             >=1.5   && <1.7
     , directory             ^>=1.3
     , hspec                 ^>=2.11
     , monad-bayes
-    , optparse-applicative  >=0.17   && <0.19
+    , optparse-applicative  >=0.17  && <0.19
     , process               ^>=1.6
     , QuickCheck            ^>=2.14
-    , time                  >=1.9    && <1.13
-    , transformers          ^>=0.5.6
+    , time                  >=1.9   && <1.13
     , typed-process         ^>=0.2
 
   autogen-modules: Paths_monad_bayes

src/Control/Applicative/List.hs

@@ -0,0 +1,23 @@
+{-# LANGUAGE StandaloneDeriving #-}
+
+module Control.Applicative.List where
+
+-- base
+import Control.Applicative
+import Data.Functor.Compose
+
+-- * Applicative ListT
+
+-- | _Applicative_ transformer adding a list/nondeterminism/choice effect.
+--   It is not a valid monad transformer, but it is a valid 'Applicative'.
+newtype ListT m a = ListT {getListT :: Compose m [] a}
+  deriving newtype (Functor, Applicative, Alternative)
+
+listT :: m [a] -> ListT m a
+listT = ListT . Compose
+
+lift :: (Functor m) => m a -> ListT m a
+lift = ListT . Compose . fmap pure
+
+runListT :: ListT m a -> m [a]
+runListT = getCompose . getListT

src/Control/Monad/Bayes/Class.hs

@@ -77,11 +77,11 @@ where
 import Control.Arrow (Arrow (second))
 import Control.Monad (replicateM, when)
 import Control.Monad.Cont (ContT)
-import Control.Monad.Except (ExceptT, lift)
+import Control.Monad.Except (ExceptT)
 import Control.Monad.Identity (IdentityT)
-import Control.Monad.List (ListT)
 import Control.Monad.Reader (ReaderT)
 import Control.Monad.State (StateT)
+import Control.Monad.Trans.Class (lift)
 import Control.Monad.Writer (WriterT)
 import Data.Histogram qualified as H
 import Data.Histogram.Fill qualified as H
@@ -390,16 +390,6 @@ instance (MonadFactor m) => MonadFactor (StateT s m) where
 
 instance (MonadMeasure m) => MonadMeasure (StateT s m)
 
-instance (MonadDistribution m) => MonadDistribution (ListT m) where
-  random = lift random
-  bernoulli = lift . bernoulli
-  categorical = lift . categorical
-
-instance (MonadFactor m) => MonadFactor (ListT m) where
-  score = lift . score
-
-instance (MonadMeasure m) => MonadMeasure (ListT m)
-
 instance (MonadDistribution m) => MonadDistribution (ContT r m) where
   random = lift random
 

src/Control/Monad/Bayes/Population.hs

@@ -1,6 +1,7 @@
 {-# LANGUAGE DerivingStrategies #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE ImportQualifiedPost #-}
+{-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE RankNTypes #-}
 {-# OPTIONS_GHC -Wno-deprecations #-}
 
@@ -37,11 +38,12 @@ module Control.Monad.Bayes.Population
   )
 where
 
+import Control.Applicative (Alternative)
 import Control.Arrow (second)
-import Control.Monad (replicateM)
+import Control.Monad (forM, replicateM)
 import Control.Monad.Bayes.Class
-  ( MonadDistribution (categorical, logCategorical, random, uniform),
-    MonadFactor,
+  ( MonadDistribution (..),
+    MonadFactor (..),
     MonadMeasure,
     factor,
   )
@@ -52,7 +54,9 @@ import Control.Monad.Bayes.Weighted
     runWeightedT,
     weightedT,
   )
-import Control.Monad.List (ListT (..), MonadIO, MonadTrans (..))
+import Control.Monad.IO.Class
+import Control.Monad.Trans.Class
+import Data.Functor.Compose
 import Data.List (unfoldr)
 import Data.List qualified
 import Data.Maybe (catMaybes)
@@ -62,6 +66,40 @@ import Numeric.Log (Log, ln, sum)
 import Numeric.Log qualified as Log
 import Prelude hiding (all, sum)
 
+-- | The old-fashioned, broken list transformer, adding a list/nondeterminism/choice effect.
+--   It is not a valid monad transformer, but it is a valid 'Applicative'.
+newtype ListT m a = ListT {getListT :: Compose m [] a}
+  deriving newtype (Functor, Applicative, Alternative)
+
+listT :: m [a] -> ListT m a
+listT = ListT . Compose
+
+runListT :: ListT m a -> m [a]
+runListT = getCompose . getListT
+
+-- | This monad instance is _unlawful_,
+-- it is only by accident and careful construction that it can be used here.
+instance (Monad m) => Monad (ListT m) where
+  ma >>= f = ListT $ Compose $ do
+    as <- runListT ma
+    fmap concat $ forM as $ runListT . f
+
+instance MonadTrans ListT where
+  lift = ListT . Compose . fmap pure
+
+instance (MonadIO m) => MonadIO (ListT m) where
+  liftIO = lift . liftIO
+
+instance (MonadDistribution m) => MonadDistribution (ListT m) where
+  random = lift random
+  bernoulli = lift . bernoulli
+  categorical = lift . categorical
+
+instance (MonadFactor m) => MonadFactor (ListT m) where
+  score = lift . score
+
+instance (MonadMeasure m) => MonadMeasure (ListT m)
+
 -- | A collection of weighted samples, or particles.
 newtype PopulationT m a = PopulationT {getPopulationT :: WeightedT (ListT m) a}
   deriving newtype (Functor, Applicative, Monad, MonadIO, MonadDistribution, MonadFactor, MonadMeasure)
@@ -80,7 +118,7 @@ explicitPopulation = fmap (map (second (exp . ln))) . runPopulationT
 
 -- | Initialize 'PopulationT' with a concrete weighted sample.
 fromWeightedList :: (Monad m) => m [(a, Log Double)] -> PopulationT m a
-fromWeightedList = PopulationT . weightedT . ListT
+fromWeightedList = PopulationT . weightedT . listT
 
 -- | Increase the sample size by a given factor.
 -- The weights are adjusted such that their sum is preserved.

test/TestWeighted.hs

@@ -2,14 +2,14 @@
 
 module TestWeighted (check, passed, result, model) where
 
+import Control.Monad (unless, when)
 import Control.Monad.Bayes.Class
   ( MonadDistribution (normal, uniformD),
     MonadMeasure,
     factor,
   )
 import Control.Monad.Bayes.Sampler.Strict (sampleIOfixed)
 import Control.Monad.Bayes.Weighted (runWeightedT)
-import Control.Monad.State (unless, when)
 import Data.AEq (AEq ((~==)))
 import Data.Bifunctor (second)
 import Numeric.Log (Log (Exp, ln))