weighted 0.3.0.0 → 0.3.0.1

raw patch · 4 files changed

+147/−43 lines, 4 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• src/Control/Monad/Weighted.hs +90/−20
• src/Control/Monad/Weighted/Class.hs +11/−3
• src/Control/Monad/Weighted/Filter.hs +45/−19
• weighted.cabal +1/−1

@@ -2,73 +2,139 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses      #-} {-# LANGUAGE PatternSynonyms            #-}+{-# LANGUAGE Strict                     #-} {-# LANGUAGE UndecidableInstances       #-} {-# LANGUAGE ViewPatterns               #-} +-- | This module provides monad transformer similar to+-- 'Control.Monad.Writer.Strict.WriterT', implemented using 'StateT', making it+-- tail recursive. (The traditional writer always leaks space: see+-- <https://mail.haskell.org/pipermail/libraries/2013-March/019528.html here>+-- for more information).+--+-- <https://downloads.haskell.org/~ghc/latest/docs/html/users_guide/glasgow_exts.html#pattern-synonyms Pattern Synonyms>+-- are used to provide the same interface as+-- 'Control.Monad.Writer.Strict.WriterT'. Unfortunately, current GHC warns+-- whenever these patterns are used that there are unmatched patterns: the+-- <https://ghc.haskell.org/trac/ghc/ticket/8779 COMPLETE> pragma should solve+-- this problem in future version of GHC.+--+-- A pattern synonym is also provided for a non-transformer version of writer.+-- Again, this is just 'StateT' underneath, but its interface looks as if it was+-- defined like so:+--+-- > newtype Writer w a = Writer { runWriter :: (a, w) }+--+-- The other difference between this monad and+-- 'Control.Monad.Writer.Strict.WriterT' is that it relies on '<.>' from+-- 'Semiring', rather than 'mappend' from 'Monoid'. module Control.Monad.Weighted-  (WeightedT+  (+   -- * Transformer+   WeightedT   ,runWeightedT   ,pattern WeightedT-  ,Weighted-  ,runWeighted-  ,pattern Weighted   ,execWeightedT   ,evalWeightedT+  ,+   -- * Plain+   Weighted+  ,runWeighted+  ,pattern Weighted   ,execWeighted   ,evalWeighted)   where - import           Control.Applicative-import           Control.Monad.Identity-import           Control.Monad.State.Strict -import           Control.Monad.Cont.Class-import           Control.Monad.Error.Class import           Control.Monad.Fail+import           Control.Monad.Identity+ import           Control.Monad.Reader.Class+import           Control.Monad.Weighted.Class import           Control.Monad.Writer.Class+import           Control.Monad.Cont.Class+import           Control.Monad.Error.Class -import           Control.Monad.Weighted.Class+import           Control.Monad.State.Strict  import           Data.Coerce+ import           Data.Functor.Classes  import           Data.Monoid import           Data.Semiring --- | A monad transformer similar to 'WriterT', except that it does not leak--- space, and it uses the 'Semiring' class, rather than 'Monoid'.+-- | A monad transformer similar to 'Control.Monad.Writer.Strict.WriterT', except+-- that it does not leak space. It is implemented using a state monad, so that+-- `mappend` is tail recursive. See+-- <https://mail.haskell.org/pipermail/libraries/2013-March/019528.html this>+-- email to the Haskell libraries committee for more information.+--+-- It also uses '<.>' from 'Semiring', rather than 'mappend' from 'Monoid' when+-- combining computations.+--+-- Wherever possible, coercions are used to eliminate any overhead from the+-- newtype wrapper. newtype WeightedT s m a =     WeightedT_ (StateT s m a)-    deriving (Functor,Applicative,Monad,MonadTrans,MonadCont,MonadError e-             ,MonadReader r,MonadFix,MonadFail,MonadIO,Alternative,MonadPlus-             ,MonadWriter w)+    deriving (Functor,Applicative,Monad,MonadTrans,MonadCont+             ,MonadError e,MonadReader r,MonadFix,MonadFail+             ,MonadIO,Alternative,MonadPlus,MonadWriter w) +-- | Run a weighted computation in the underlying monad. runWeightedT     :: Semiring s     => WeightedT s m a -> m (a, s) runWeightedT =     (coerce :: (StateT s m a -> m (a, s)) -> WeightedT s m a -> m (a, s))         (`runStateT` one)+ {-# INLINE runWeightedT #-} +{-# ANN module "HLint: ignore Use second" #-} +-- | This pattern gives the newtype wrapper around 'StateT' the same interface+-- as 'Control.Monad.Writer.Strict.WriterT'. Unfortunately, GHC currently warns+-- that a function is incomplete wherever this pattern is used. This issue+-- should be solved in a future version of GHC, when the+-- <https://ghc.haskell.org/trac/ghc/ticket/8779 COMPLETE> pragma is+-- implemented. pattern WeightedT :: (Functor m, Semiring s) =>         m (a, s) -> WeightedT s m a  pattern WeightedT x <- (runWeightedT -> x)   where WeightedT y-          = WeightedT_ (StateT (\ s -> (fmap . fmap) (s<.>) y))+          = WeightedT_ (StateT (\ s -> fmap (\ (x, p) -> (x, s <.> p)) y)) +-- | A type synonym for the plain (non-transformer) version of 'Weighted'. This+-- can be used as if it were defined as:+--+-- > newtype Weighted w a = Weighted { runWeighted :: (a, w) } type Weighted s = WeightedT s Identity +-- | This pattern gives the newtype wrapper around 'StateT' the same interface+-- as as if it was defined like so:+--+-- > newtype Weighted w a = Weighted { runWeighted :: (a, w) }+--+-- Unfortunately GHC warns that a function is incomplete wherever this pattern+-- is used. This issue should be solved in a future version of GHC, when the+-- <https://ghc.haskell.org/trac/ghc/ticket/8779 COMPLETE> pragma is+-- implemented.+--+-- >>> execWeighted $ traverse (\x -> Weighted ((), x)) [1..5]+-- 120 pattern Weighted :: Semiring s => (a, s) -> Weighted s a  pattern Weighted x <- (runWeighted -> x)   where Weighted (y, p)           = WeightedT_ (StateT (\ s -> Identity (y, (<.>) p s))) +-- | Run a weighted computation.+--+-- >>> runWeighted $ traverse (\x -> Weighted (show x, x)) [1..5]+-- (["1","2","3","4","5"],120) runWeighted     :: Semiring s     => Weighted s a -> (a, s)@@ -84,6 +150,7 @@     put = lift . put     state = lift . state +-- | Run a weighted computation in the underlying monad, and return its result. evalWeightedT     :: (Monad m, Semiring s)     => WeightedT s m a -> m a@@ -93,6 +160,7 @@  {-# INLINE evalWeightedT #-} +-- | Run a weighted computation in the underlying monad, and collect its weight. execWeightedT     :: (Monad m, Semiring s)     => WeightedT s m a -> m s@@ -102,6 +170,7 @@  {-# INLINE execWeightedT #-} +-- | Run a weighted computation, and return its result. evalWeighted     :: Semiring s     => Weighted s a -> a@@ -110,6 +179,7 @@  {-# INLINE evalWeighted #-} +-- | Run a weighted computation, and collect its weight. execWeighted     :: Semiring s     => Weighted s a -> s@@ -156,7 +226,8 @@ instance (Read w, Read1 m, Semiring w, Functor m) =>          Read1 (WeightedT w m) where     liftReadsPrec rp rl =-        readsData $ readsUnaryWith (liftReadsPrec rp' rl') "WeightedT" WeightedT+        readsData $+        readsUnaryWith (liftReadsPrec rp' rl') "WeightedT" WeightedT       where         rp' = liftReadsPrec2 rp rl readsPrec readList         rl' = liftReadList2 rp rl readsPrec readList@@ -185,7 +256,8 @@          Show (WeightedT w m a) where     showsPrec = showsPrec1 -instance (Semiring w, Monad m) => MonadWeighted w (WeightedT w m) where+instance (Semiring w, Monad m) =>+         MonadWeighted w (WeightedT w m) where     weighted (x,s) = WeightedT (pure (x, s))     {-# INLINE weighted #-}     weigh (WeightedT_ s) = WeightedT_ ((,) <$> s <*> get)@@ -194,5 +266,3 @@       where         scaleS = (=<<) (uncurry (<$) . fmap modify)     {-# INLINE scale #-}--

@@ -2,7 +2,11 @@ {-# LANGUAGE FlexibleInstances      #-} {-# LANGUAGE UndecidableInstances   #-} -module Control.Monad.Weighted.Class where+module Control.Monad.Weighted.Class+  ( MonadWeighted(..)+  , collect+  , toCovector+  ) where  import qualified Control.Monad.Trans.Identity as Identity import qualified Control.Monad.Trans.Except as Except@@ -17,6 +21,8 @@  import Data.Coerce +-- | A class for computations which carry a weight with them. It is analogous+-- to 'Control.Monad.Writer.Writer' over the 'Data.Monoid.Product' 'Monoid'. class (Semiring w, Monad m) => MonadWeighted w m | m -> w where     {-# MINIMAL (weighted | weight), weigh, scale #-}     -- | @'weighted' (a,w)@ embeds a simple weighted action.@@ -73,6 +79,7 @@     weigh    = Reader.mapReaderT weigh     scale    = Reader.mapReaderT scale +-- | Collect the total weight of a computation. collect :: (Foldable m, MonadWeighted w m) => m a -> w collect = getAdd  #. foldMap (Add #. snd) . weigh @@ -80,5 +87,6 @@ (#.) :: Coercible b c => (b -> c) -> (a -> b) -> a -> c (#.) _ = coerce -toCont :: (Foldable m, MonadWeighted w m) => (a -> w) -> m a -> w-toCont f xs = collect (weight . f =<< xs)+-- | Transform a weighted computation to a covector.+toCovector :: (Foldable m, MonadWeighted w m) => m a -> (a -> w) -> w+toCovector xs f = collect (weight . f =<< xs)

@@ -1,13 +1,15 @@ {-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE Strict                     #-} {-# LANGUAGE UndecidableInstances       #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses      #-} {-# LANGUAGE PatternSynonyms            #-} {-# LANGUAGE ViewPatterns               #-} +-- | This module provides a weighted monad which filters out zero-weighted+-- results from a  computation at every opportunity. module Control.Monad.Weighted.Filter-  (catchZero-  ,FilterT+  (FilterT   ,pattern FilterT   ,runFilterT   ,evalFilterT@@ -29,25 +31,39 @@ import           Control.Monad.Weighted.Class import           Control.Monad.Writer.Class -import           Control.Arrow                (first) import           Data.Coerce import           Data.Monoid -catchZero :: (DetectableZero s, Alternative m) => (s -> m a) -> s -> m a-catchZero f s | isZero s = empty-              | otherwise = f s+first :: (a -> b) -> (a, c) -> (b, c)+first f (x, y) = (f x, y) -remZeroes :: (DetectableZero s, Alternative m, Monad m) => m (a, s) -> m (a, s)-remZeroes xs = xs >>=  (\(x,p) -> if isZero p then empty else pure (x,p))+catchZero+    :: (DetectableZero s, Alternative m)+    => (s -> m a) -> s -> m a+catchZero f s+  | isZero s = empty+  | otherwise = f s --- | Discards results which are zero-newtype FilterT s m a =-    FilterT_ { unFilterT :: StateT s m a }-    deriving (MonadTrans,MonadCont,MonadError e-             ,MonadReader r,MonadFix,MonadFail,MonadIO,Alternative,MonadPlus-             ,MonadWriter w)+{-# INLINE catchZero #-} -instance (Alternative m, DetectableZero s) => Functor (FilterT s m) where+remZeroes+    :: (DetectableZero s, Alternative m, Monad m)+    => m (a, s) -> m (a, s)+remZeroes xs =+    xs >>=+    (\(x,p) ->+          if isZero p+              then empty+              else pure (x, p))++-- | A weighted monad which discards results which are zero as it goes.+newtype FilterT s m a = FilterT_+    { unFilterT :: StateT s m a+    } deriving (MonadTrans,MonadCont,MonadError e,MonadReader r,MonadFix+               ,MonadFail,MonadIO,Alternative,MonadPlus,MonadWriter w)++instance (Alternative m, DetectableZero s) =>+         Functor (FilterT s m) where     fmap f (FilterT_ (StateT st)) =         (FilterT_ . StateT . catchZero) ((fmap . first) f . st)     {-# INLINE fmap #-}@@ -80,15 +96,18 @@                 s''     {-# INLINE (>>=) #-} +-- | Run a filtered computation in the underlying monad. runFilterT     :: (DetectableZero s, Alternative m, Monad m)     => FilterT s m a -> m (a, s)-runFilterT = remZeroes .+runFilterT =+    remZeroes .     (coerce :: (StateT s m a -> m (a, s)) -> FilterT s m a -> m (a, s))         (`runStateT` one)  {-# INLINE runFilterT #-} +-- | Evaluate a filtered computation in the underlying monad and return its result. evalFilterT     :: (Monad m, Semiring s)     => FilterT s m a -> m a@@ -98,6 +117,7 @@  {-# INLINE evalFilterT #-} +-- | Evaluate a filtered computation in the underlying monad and collect its weight. execFilterT     :: (Monad m, Semiring s)     => FilterT s m a -> m s@@ -107,11 +127,17 @@  {-# INLINE execFilterT #-} -pattern FilterT :: (Alternative m, DetectableZero s, Monad m) => m (a, s) -> FilterT s m a+-- | This pattern gives an interface to the 'FilterT' monad which makes it look as if+-- it were defined without the state monad.+pattern FilterT :: (Alternative m, DetectableZero s, Monad m) =>+        m (a, s) -> FilterT s m a+ pattern FilterT x <- (runFilterT -> x)-  where FilterT y = FilterT_ . StateT . catchZero $ \s -> (fmap.fmap) (s<.>) y+  where FilterT y+          = FilterT_ . StateT . catchZero $ \ s -> (fmap . fmap) (s <.>) y -instance (DetectableZero w, Monad m, Alternative m) => MonadWeighted w (FilterT w m) where+instance (DetectableZero w, Monad m, Alternative m) =>+         MonadWeighted w (FilterT w m) where     weighted (x,s) = FilterT (pure (x, s))     {-# INLINE weighted #-}     weigh (FilterT_ s) = FilterT_ ((,) <$> s <*> get)

@@ -1,5 +1,5 @@ name:                weighted-version:             0.3.0.0+version:             0.3.0.1 synopsis:            Writer monad which uses semiring constraint description:         Writer monad which uses semiring constraint homepage:            https://github.com/oisdk/weighted