weighted 0.1.0.1 → 0.3.0.0

raw patch · 4 files changed

+415/−28 lines, 4 filesdep +transformersdep ~semiring-numPVP ok

version bump matches the API change (PVP)

Dependencies added: transformers

Dependency ranges changed: semiring-num

API changes (from Hackage documentation)

Files

• src/Control/Monad/Weighted.hs +129/−26
• src/Control/Monad/Weighted/Class.hs +84/−0
• src/Control/Monad/Weighted/Filter.hs +197/−0
• weighted.cabal +5/−2

@@ -1,6 +1,8 @@+{-# LANGUAGE FlexibleInstances          #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses      #-} {-# LANGUAGE PatternSynonyms            #-}+{-# LANGUAGE UndecidableInstances       #-} {-# LANGUAGE ViewPatterns               #-}  module Control.Monad.Weighted@@ -16,18 +18,32 @@   ,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.Reader.Class import           Control.Monad.Writer.Class++import           Control.Monad.Weighted.Class+ 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'. newtype WeightedT s m a =     WeightedT_ (StateT s m a)-    deriving (Functor,Applicative,Monad,MonadTrans)+    deriving (Functor,Applicative,Monad,MonadTrans,MonadCont,MonadError e+             ,MonadReader r,MonadFix,MonadFail,MonadIO,Alternative,MonadPlus+             ,MonadWriter w)  runWeightedT     :: Semiring s@@ -37,59 +53,146 @@         (`runStateT` one) {-# INLINE runWeightedT #-} -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)) +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))+ type Weighted s = WeightedT s Identity  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))) +pattern Weighted x <- (runWeighted -> x)+  where Weighted (y, p)+          = WeightedT_ (StateT (\ s -> Identity (y, (<.>) p s)))+ runWeighted     :: Semiring s     => Weighted s a -> (a, s) runWeighted =     (coerce :: (WeightedT s Identity a -> Identity (a, s)) -> (WeightedT s Identity a -> (a, s)))         runWeightedT+ {-# INLINE runWeighted #-} -instance (Semiring s, Monad m) => MonadWriter (Mul s) (WeightedT s m) where-  writer (x, Mul s) = WeightedT (pure (x, s))-  {-# INLINE writer #-}-  listen (WeightedT_ s) = WeightedT_ ((,) <$> s <*> gets Mul)-  {-# INLINE listen #-}-  pass (WeightedT_ s) = WeightedT_ (passS s) where-    passS = (=<<) (uncurry (<$) . fmap (modify . coerce))-  {-# INLINE pass #-}+instance MonadState s m =>+         MonadState s (WeightedT w m) where+    get = lift get+    put = lift . put+    state = lift . state -evalWeightedT :: (Monad m, Semiring s) => WeightedT s m a -> m a+evalWeightedT+    :: (Monad m, Semiring s)+    => WeightedT s m a -> m a evalWeightedT =     (coerce :: (StateT s m a -> m a) -> WeightedT s m a -> m a)         (`evalStateT` one)+ {-# INLINE evalWeightedT #-} -execWeightedT :: (Monad m, Semiring s) => WeightedT s m a -> m s+execWeightedT+    :: (Monad m, Semiring s)+    => WeightedT s m a -> m s execWeightedT =     (coerce :: (StateT s m a -> m s) -> WeightedT s m a -> m s)         (`execStateT` one)+ {-# INLINE execWeightedT #-} -evalWeighted :: Semiring s => Weighted s a -> a+evalWeighted+    :: Semiring s+    => Weighted s a -> a evalWeighted =-    (coerce :: (State s a -> a) -> Weighted s a -> a)-        (`evalState` one)+    (coerce :: (State s a -> a) -> Weighted s a -> a) (`evalState` one)+ {-# INLINE evalWeighted #-} -execWeighted :: Semiring s => Weighted s a -> s+execWeighted+    :: Semiring s+    => Weighted s a -> s execWeighted =-    (coerce :: (State s a -> s) -> Weighted s a -> s)-        (`execState` one)+    (coerce :: (State s a -> s) -> Weighted s a -> s) (`execState` one)+ {-# INLINE execWeighted #-} -instance (Alternative m, Monad m, Semiring s) => Alternative (WeightedT s m) where-  empty = WeightedT empty-  WeightedT x <|> WeightedT y = WeightedT (x <|> y)-  _ <|> _ = undefined+instance (Foldable m, Semiring w) =>+         Foldable (WeightedT w m) where+    foldMap f =+        foldMap+            (\(x,_) ->+                  f x) .+        runWeightedT++first_+    :: Applicative f+    => (a -> f b) -> (a, c) -> f (b, c)+first_ f (x,y) = flip (,) y <$> f x++instance (Traversable m, Semiring w) =>+         Traversable (WeightedT w m) where+    traverse f x = WeightedT <$> (traverse . first_) f (runWeightedT x)++instance (Eq1 m, Eq w, Semiring w) =>+         Eq1 (WeightedT w m) where+    liftEq eq x y =+        liftEq+            (\(xx,xy) (yx,yy) ->+                  eq xx yx && xy == yy)+            (runWeightedT x)+            (runWeightedT y)++instance (Ord1 m, Ord w, Semiring w) =>+         Ord1 (WeightedT w m) where+    liftCompare cmp x y =+        liftCompare+            (\(xx,xy) (yx,yy) ->+                  cmp xx yx <> compare xy yy)+            (runWeightedT x)+            (runWeightedT y)++instance (Read w, Read1 m, Semiring w, Functor m) =>+         Read1 (WeightedT w m) where+    liftReadsPrec rp rl =+        readsData $ readsUnaryWith (liftReadsPrec rp' rl') "WeightedT" WeightedT+      where+        rp' = liftReadsPrec2 rp rl readsPrec readList+        rl' = liftReadList2 rp rl readsPrec readList++instance (Show w, Show1 m, Semiring w) =>+         Show1 (WeightedT w m) where+    liftShowsPrec sp sl d m =+        showsUnaryWith (liftShowsPrec sp' sl') "WeightedT" d (runWeightedT m)+      where+        sp' = liftShowsPrec2 sp sl showsPrec showList+        sl' = liftShowList2 sp sl showsPrec showList++instance (Eq w, Eq1 m, Eq a, Semiring w) =>+         Eq (WeightedT w m a) where+    (==) = eq1++instance (Ord w, Ord1 m, Ord a, Semiring w) =>+         Ord (WeightedT w m a) where+    compare = compare1++instance (Read w, Read1 m, Read a, Semiring w, Functor m) =>+         Read (WeightedT w m a) where+    readsPrec = readsPrec1++instance (Show w, Show1 m, Show a, Semiring w) =>+         Show (WeightedT w m a) where+    showsPrec = showsPrec1++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)+    {-# INLINE weigh #-}+    scale (WeightedT_ s) = WeightedT_ (scaleS s)+      where+        scaleS = (=<<) (uncurry (<$) . fmap modify)+    {-# INLINE scale #-}+ 

@@ -0,0 +1,84 @@+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE FlexibleInstances      #-}+{-# LANGUAGE UndecidableInstances   #-}++module Control.Monad.Weighted.Class where++import qualified Control.Monad.Trans.Identity as Identity+import qualified Control.Monad.Trans.Except as Except+import qualified Control.Monad.Trans.State.Strict as StateStrict+import qualified Control.Monad.Trans.State.Lazy as StateLazy+import qualified Control.Monad.Trans.Maybe as Maybe+import qualified Control.Monad.Trans.Reader as Reader++import Control.Monad.Trans (lift)++import Data.Semiring++import Data.Coerce++class (Semiring w, Monad m) => MonadWeighted w m | m -> w where+    {-# MINIMAL (weighted | weight), weigh, scale #-}+    -- | @'weighted' (a,w)@ embeds a simple weighted action.+    weighted :: (a,w) -> m a+    weighted ~(a, w) = do+      weight w+      return a++    -- | @'weight' w@ is an action that produces the output @w@.+    weight   :: w -> m ()+    weight w = weighted ((),w)++    -- | @'weigh' m@ is an action that executes the action @m@ and adds+    -- its output to the value of the computation.+    weigh :: m a -> m (a, w)+    -- | @'scale' m@ is an action that executes the action @m@, which+    -- returns a value and a function, and returns the value, applying+    -- the function to the output.+    scale   :: m (a, w -> w) -> m a++instance MonadWeighted w m => MonadWeighted w (Except.ExceptT e m) where+    weighted = lift . weighted+    weight   = lift . weight+    weigh    = Except.liftListen weigh+    scale    = Except.liftPass scale++instance MonadWeighted w m => MonadWeighted w (Identity.IdentityT m) where+    weighted = lift . weighted+    weight   = lift . weight+    weigh    = Identity.mapIdentityT weigh+    scale    = Identity.mapIdentityT scale++instance MonadWeighted w m => MonadWeighted w (StateStrict.StateT s m) where+    weighted = lift . weighted+    weight   = lift . weight+    weigh    = StateStrict.liftListen weigh+    scale    = StateStrict.liftPass scale++instance MonadWeighted w m => MonadWeighted w (StateLazy.StateT s m) where+    weighted = lift . weighted+    weight   = lift . weight+    weigh    = StateLazy.liftListen weigh+    scale    = StateLazy.liftPass scale++instance MonadWeighted w m => MonadWeighted w (Maybe.MaybeT m) where+    weighted = lift . weighted+    weight   = lift . weight+    weigh    = Maybe.liftListen weigh+    scale    = Maybe.liftPass scale++instance MonadWeighted w m => MonadWeighted w (Reader.ReaderT r m) where+    weighted = lift . weighted+    weight   = lift . weight+    weigh    = Reader.mapReaderT weigh+    scale    = Reader.mapReaderT scale++collect :: (Foldable m, MonadWeighted w m) => m a -> w+collect = getAdd  #. foldMap (Add #. snd) . weigh++infixr 9 #.+(#.) :: 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)

@@ -0,0 +1,197 @@+{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE UndecidableInstances       #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses      #-}+{-# LANGUAGE PatternSynonyms            #-}+{-# LANGUAGE ViewPatterns               #-}++module Control.Monad.Weighted.Filter+  (catchZero+  ,FilterT+  ,pattern FilterT+  ,runFilterT+  ,evalFilterT+  ,execFilterT)+  where++import           Data.Semiring++import           Data.Functor.Classes++import           Control.Applicative++import           Control.Monad.State.Strict++import           Control.Monad.Cont.Class+import           Control.Monad.Error.Class+import           Control.Monad.Fail+import           Control.Monad.Reader.Class+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++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))++-- | 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)++instance (Alternative m, DetectableZero s) => Functor (FilterT s m) where+    fmap f (FilterT_ (StateT st)) =+        (FilterT_ . StateT . catchZero) ((fmap . first) f . st)+    {-# INLINE fmap #-}++instance (Alternative m, Monad m, DetectableZero s) =>+         Applicative (FilterT s m) where+    pure x = (FilterT_ . StateT) (catchZero (pure . (,) x))+    {-# INLINE pure #-}+    FilterT_ (StateT fs) <*> FilterT_ (StateT xs) =+        FilterT_ . StateT . catchZero $+        \s -> do+            (f,s') <- fs s+            (x,s'') <- catchZero xs s'+            catchZero+                (\s''' ->+                      pure (f x, s'''))+                s''+    {-# INLINE (<*>) #-}++instance (Alternative m, Monad m, DetectableZero s) =>+         Monad (FilterT s m) where+    FilterT_ (StateT st) >>= f =+        FilterT_ . StateT . catchZero $+        \s -> do+            (x,s') <- st s+            (y,s'') <- catchZero (runStateT (unFilterT (f x))) s'+            catchZero+                (\s''' ->+                      pure (y, s'''))+                s''+    {-# INLINE (>>=) #-}++runFilterT+    :: (DetectableZero s, Alternative m, Monad m)+    => FilterT s m a -> m (a, s)+runFilterT = remZeroes .+    (coerce :: (StateT s m a -> m (a, s)) -> FilterT s m a -> m (a, s))+        (`runStateT` one)++{-# INLINE runFilterT #-}++evalFilterT+    :: (Monad m, Semiring s)+    => FilterT s m a -> m a+evalFilterT =+    (coerce :: (StateT s m a -> m a) -> FilterT s m a -> m a)+        (`evalStateT` one)++{-# INLINE evalFilterT #-}++execFilterT+    :: (Monad m, Semiring s)+    => FilterT s m a -> m s+execFilterT =+    (coerce :: (StateT s m a -> m s) -> FilterT s m a -> m s)+        (`execStateT` one)++{-# INLINE execFilterT #-}++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++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)+    {-# INLINE weigh #-}+    scale (FilterT_ s) = FilterT_ (scaleS s)+      where+        scaleS = (=<<) (uncurry (<$) . fmap modify)+    {-# INLINE scale #-}++instance (Foldable m, DetectableZero w, Alternative m, Monad m) =>+         Foldable (FilterT w m) where+    foldMap f =+        foldMap+            (\(x,p) ->+                  if isZero p+                      then mempty+                      else f x) .+        runFilterT++first_+    :: Applicative f+    => (a -> f b) -> (a, c) -> f (b, c)+first_ f (x,y) = flip (,) y <$> f x++instance (Traversable m, DetectableZero w, Alternative m, Monad m) =>+         Traversable (FilterT w m) where+    traverse f x = FilterT <$> (traverse . first_) f (runFilterT x)++instance (Eq1 m, Eq w, DetectableZero w, Monad m, Alternative m) =>+         Eq1 (FilterT w m) where+    liftEq eq x y =+        liftEq+            (\(xx,xy) (yx,yy) ->+                  eq xx yx && xy == yy)+            (runFilterT x)+            (runFilterT y)++instance (Ord1 m, Ord w, DetectableZero w, Monad m, Alternative m) =>+         Ord1 (FilterT w m) where+    liftCompare cmp x y =+        liftCompare+            (\(xx,xy) (yx,yy) ->+                  cmp xx yx <> compare xy yy)+            (runFilterT x)+            (runFilterT y)++instance (Read w, Read1 m, DetectableZero w, Alternative m, Monad m) =>+         Read1 (FilterT w m) where+    liftReadsPrec rp rl =+        readsData $ readsUnaryWith (liftReadsPrec rp' rl') "FilterT" FilterT+      where+        rp' = liftReadsPrec2 rp rl readsPrec readList+        rl' = liftReadList2 rp rl readsPrec readList++instance (Show w, Show1 m, DetectableZero w, Monad m, Alternative m) =>+         Show1 (FilterT w m) where+    liftShowsPrec sp sl d m =+        showsUnaryWith (liftShowsPrec sp' sl') "FilterT" d (runFilterT m)+      where+        sp' = liftShowsPrec2 sp sl showsPrec showList+        sl' = liftShowList2 sp sl showsPrec showList++instance (Eq w, Eq1 m, Eq a, DetectableZero w, Monad m, Alternative m) =>+         Eq (FilterT w m a) where+    (==) = eq1++instance (Ord w, Ord1 m, Ord a, DetectableZero w, Monad m, Alternative m) =>+         Ord (FilterT w m a) where+    compare = compare1++instance (Read w, Read1 m, Read a, DetectableZero w, Alternative m, Monad m) =>+         Read (FilterT w m a) where+    readsPrec = readsPrec1++instance (Show w, Show1 m, Show a, DetectableZero w, Alternative m, Monad m) =>+         Show (FilterT w m a) where+    showsPrec = showsPrec1++instance (Alternative m, MonadState s m, DetectableZero w) =>+         MonadState s (FilterT w m) where+    get = lift get+    put = lift . put+    state = lift . state

@@ -1,5 +1,5 @@ name:                weighted-version:             0.1.0.1+version:             0.3.0.0 synopsis:            Writer monad which uses semiring constraint description:         Writer monad which uses semiring constraint homepage:            https://github.com/oisdk/weighted@@ -15,9 +15,12 @@ library   hs-source-dirs:      src   exposed-modules:     Control.Monad.Weighted+                     , Control.Monad.Weighted.Filter+                     , Control.Monad.Weighted.Class   build-depends:       base >= 4.9 && < 5-                     , semiring-num >= 0.5.1.1+                     , semiring-num >= 0.9                      , mtl >= 2.2+                     , transformers >= 0.5   default-language:    Haskell2010  source-repository head