polysemy 0.6.0.0 → 0.7.0.0

raw patch · 14 files changed

+192/−70 lines, 14 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• ChangeLog.md +17/−0
• polysemy.cabal +7/−6
• src/Polysemy/Error.hs +6/−4
• src/Polysemy/IO.hs +4/−4
• src/Polysemy/Internal.hs +1/−1
• src/Polysemy/Internal/Combinators.hs +7/−7
• src/Polysemy/Internal/Tactics.hs +3/−3
• src/Polysemy/Internal/Union.hs +49/−30
• src/Polysemy/NonDet.hs +2/−2
• src/Polysemy/Reader.hs +1/−1
• src/Polysemy/State.hs +3/−3
• src/Polysemy/Writer.hs +19/−6
• test/FusionSpec.hs +14/−3
• test/WriterSpec.hs +59/−0

@@ -1,5 +1,19 @@ # Changelog for polysemy +## 0.7.0.0 (2019-07-08)++### Breaking Changes++- Added a `Pass` constructor to `Writer`+- Fixed a bug in `runWriter` where the MTL semantics wouldn't be respected+- Removed the `Censor` constructor of `Writer`+- Renamed `Yo` to `Weaving`+- Changed the visible type applications for `asks`, `gets`, and `runErrorAsAnother`++### Other Changes++- Fixed haddock generation+ ## 0.6.0.0 (2019-07-04)  ### Breaking Changes@@ -130,4 +144,7 @@ - Initial release  ## Unreleased changes++- Changed the tyvars of `fromEitherM`, `runErrorAsAnother`, `runEmbedded`,+  `asks` and `gets` 

@@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: fd80d4218e2d56a0c2af9f4bd89fc79c0ebce4fe968415430a6009ee91205586+-- hash: e22afd49cd8b82cdc69be962d872539c65eedc43a2978aa7a0652b40dd7db105  name:           polysemy-version:        0.6.0.0+version:        0.7.0.0 synopsis:       Higher-order, low-boilerplate, zero-cost free monads. description:    Please see the README on GitHub at <https://github.com/isovector/polysemy#readme> category:       Language@@ -85,7 +85,7 @@     , unagi-chan >=0.4.0.0 && <0.5   if impl(ghc < 8.6)     default-extensions: MonadFailDesugaring TypeInType-  if impl(ghc >= 8.6)+  if impl(ghc >= 8.7)     build-depends:         loopbreaker >=0.1 && <0.2   if flag(dump-core)@@ -95,7 +95,7 @@   if impl(ghc < 8.2.2)     build-depends:         unsupported-ghc-version >1 && <1-  if impl(ghc >= 8.6)+  if impl(ghc >= 8.7)     ghc-options: -fplugin=Loopbreaker   if flag(error-messages)     cpp-options: -DCABAL_SERIOUSLY_CMON_MATE@@ -118,6 +118,7 @@       OutputSpec       ThEffectSpec       TypeErrors+      WriterSpec       Paths_polysemy   hs-source-dirs:       test@@ -143,7 +144,7 @@     , unagi-chan >=0.4.0.0 && <0.5   if impl(ghc < 8.6)     default-extensions: MonadFailDesugaring TypeInType-  if impl(ghc >= 8.6)+  if impl(ghc >= 8.7)     build-depends:         loopbreaker >=0.1 && <0.2   default-language: Haskell2010@@ -175,7 +176,7 @@     , unagi-chan >=0.4.0.0 && <0.5   if impl(ghc < 8.6)     default-extensions: MonadFailDesugaring TypeInType-  if impl(ghc >= 8.6)+  if impl(ghc >= 8.7)     build-depends:         loopbreaker >=0.1 && <0.2   default-language: Haskell2010

@@ -56,7 +56,8 @@ -- -- @since 0.5.1.0 fromEitherM-    :: ( Member (Error e) r+    :: forall e m r a+     . ( Member (Error e) r        , Member (Lift m) r        )     => m (Either e a)@@ -77,8 +78,8 @@             (either (pure . Left) runError)             hush             x-    Right (Yo (Throw e) _ _ _ _) -> E.throwE e-    Right (Yo (Catch try handle) s d y _) ->+    Right (Weaving (Throw e) _ _ _ _) -> E.throwE e+    Right (Weaving (Catch try handle) s d y _) ->       E.ExceptT $ usingSem k $ do         ma <- runError $ d $ try <$ s         case ma of@@ -97,7 +98,8 @@ -- -- @since 0.2.2.0 runErrorAsAnother-  :: Member (Error e2) r+  :: forall e1 e2 r a+   . Member (Error e2) r   => (e1 -> e2)   -> Sem (Error e1 ': r) a   -> Sem r a

@@ -52,10 +52,10 @@ -- -- This function creates a thread, and so should be compiled with @-threaded@. ----- TODO(sandy): @since+-- @since 0.6.0.0 runEmbedded-    :: ( LastMember (Lift IO) r-       , MonadIO m+    :: ( MonadIO m+       , LastMember (Lift IO) r        )     => (forall x. m x -> IO x)  -- ^ The means of running this monad.     -> Sem (Lift m ': r) a@@ -68,6 +68,6 @@               . liftSem               $ hoist (runEmbedded run_m) x -      Right (Yo (Lift wd) s _ y _) ->+      Right (Weaving (Lift wd) s _ y _) ->         fmap y $ fmap (<$ s) wd 

@@ -327,7 +327,7 @@ runM :: Monad m => Sem '[Lift m] a -> m a runM (Sem m) = m $ \z ->   case extract z of-    Yo e s _ f _ -> do+    Weaving e s _ f _ -> do       a <- unLift e       pure $ f $ a <$ s {-# INLINE runM #-}

@@ -73,7 +73,7 @@ interpretH f (Sem m) = m $ \u ->   case decomp u of     Left  x -> liftSem $ hoist (interpretH f) x-    Right (Yo e s d y v) -> do+    Right (Weaving e s d y v) -> do       a <- runTactics s d v $ f e       pure $ y a {-# INLINE interpretH #-}@@ -96,7 +96,7 @@                     (uncurry $ interpretInStateT f)                     (Just . snd)             $ x-        Right (Yo e z _ y _) ->+        Right (Weaving e z _ y _) ->           fmap (y . (<$ z)) $ S.mapStateT (usingSem k) $ f e {-# INLINE interpretInStateT #-} @@ -118,7 +118,7 @@                     (uncurry $ interpretInLazyStateT f)                     (Just . snd)             $ x-        Right (Yo e z _ y _) ->+        Right (Weaving e z _ y _) ->           fmap (y . (<$ z)) $ LS.mapStateT (usingSem k) $ f e {-# INLINE interpretInLazyStateT #-} @@ -158,7 +158,7 @@ reinterpretH f (Sem m) = Sem $ \k -> m $ \u ->   case decompCoerce u of     Left x  -> k $ hoist (reinterpretH f) $ x-    Right (Yo e s d y v) -> do+    Right (Weaving e s d y v) -> do       a <- usingSem k $ runTactics s (raiseUnder . d) v $ f e       pure $ y a {-# INLINE[3] reinterpretH #-}@@ -195,7 +195,7 @@ reinterpret2H f (Sem m) = Sem $ \k -> m $ \u ->   case decompCoerce u of     Left x  -> k $ weaken $ hoist (reinterpret2H f) $ x-    Right (Yo e s d y v) -> do+    Right (Weaving e s d y v) -> do       a <- usingSem k $ runTactics s (raiseUnder2 . d) v $ f e       pure $ y a {-# INLINE[3] reinterpret2H #-}@@ -227,7 +227,7 @@ reinterpret3H f (Sem m) = Sem $ \k -> m $ \u ->   case decompCoerce u of     Left x  -> k . weaken . weaken . hoist (reinterpret3H f) $ x-    Right (Yo e s d y v) -> do+    Right (Weaving e s d y v) -> do       a <- usingSem k $ runTactics s (raiseUnder3 . d) v $ f e       pure $ y a {-# INLINE[3] reinterpret3H #-}@@ -278,7 +278,7 @@     -> Sem r a interceptH f (Sem m) = Sem $ \k -> m $ \u ->   case prj u of-    Just (Yo e s d y v) ->+    Just (Weaving e s d y v) ->       usingSem k $ fmap y $ runTactics s (raise . d) v $ f e     Nothing -> k $ hoist (interceptH f) u {-# INLINE interceptH #-}

@@ -192,11 +192,11 @@ runTactics s d v (Sem m) = m $ \u ->   case decomp u of     Left x -> liftSem $ hoist (runTactics s d v) x-    Right (Yo GetInitialState s' _ y _) ->+    Right (Weaving GetInitialState s' _ y _) ->       pure $ y $ s <$ s'-    Right (Yo (HoistInterpretation na) s' _ y _) -> do+    Right (Weaving (HoistInterpretation na) s' _ y _) -> do       pure $ y $ (d . fmap na) <$ s'-    Right (Yo GetInspector s' _ y _) -> do+    Right (Weaving GetInspector s' _ y _) -> do       pure $ y $ Inspector v <$ s' {-# INLINE runTactics #-} 

@@ -13,7 +13,7 @@  module Polysemy.Internal.Union   ( Union (..)-  , Yo (..)+  , Weaving (..)   , Member   , MemberWithError   , weave@@ -55,7 +55,7 @@          SNat n          -- The effect to wrap. The functions 'prj' and 'decomp' can help          -- retrieve this value later.-      -> Yo (IndexOf r n) m a+      -> Weaving (IndexOf r n) m a       -> Union r m a  instance Functor (Union r m) where@@ -63,17 +63,36 @@   {-# INLINE fmap #-}  -data Yo e m a where-  Yo :: Functor f-     => e m a-     -> f ()-     -> (forall x. f (m x) -> n (f x))-     -> (f a -> b)-     -> (forall x. f x -> Maybe x)-     -> Yo e n b+data Weaving e m a where+  Weaving+    :: Functor f+    =>   { weaveEffect :: e m a+         -- ^ The original effect GADT originally lifted via+         -- 'Polysemy.Internal.send'. There is an invariant that @m ~ Sem r0@,+         -- where @r0@ is the effect row that was in scope when this 'Weaving'+         -- was originally created.+       , weaveState :: f ()+         -- ^ A piece of state that other effects' interpreters have already+         -- woven through this 'Weaving'. @f@ is a 'Functor', so you can always+         -- 'fmap' into this thing.+       , weaveDistrib :: forall x. f (m x) -> n (f x)+         -- ^ Distribute @f@ by transforming @m@ into @n@. We have invariants+         -- on @m@ and @n@, which means in actuality this function looks like+         -- @f ('Polysemy.Sem' (Some ': Effects ': r) x) -> 'Polysemy.Sem' r (f+         -- x)@.+       , weaveResult :: f a -> b+         -- ^ Even though @f a@ is the moral resulting type of 'Weaving', we+         -- can't expose that fact; such a thing would prevent 'Polysemy.Sem'+         -- from being a 'Monad'.+       , weaveInspect :: forall x. f x -> Maybe x+         -- ^ A function for attempting to see inside an @f@. This is no+         -- guarantees that such a thing will succeed (for example,+         -- 'Polysemy.Error.Error' might have 'Polysemy.Error.throw'n.)+       }+    -> Weaving e n b -instance Functor (Yo e m) where-  fmap f (Yo e s d f' v) = Yo e s d (f . f') v+instance Functor (Weaving e m) where+  fmap f (Weaving e s d f' v) = Weaving e s d (f . f') v   {-# INLINE fmap #-}  @@ -85,11 +104,11 @@     -> (∀ x. s x -> Maybe x)     -> Union r m a     -> Union r n (s a)-weave s' d v' (Union w (Yo e s nt f v)) = Union w $-    Yo e (Compose $ s <$ s')-         (fmap Compose . d . fmap nt . getCompose)-         (fmap f . getCompose)-         (v <=< v' . getCompose)+weave s' d v' (Union w (Weaving e s nt f v)) = Union w $+    Weaving e (Compose $ s <$ s')+              (fmap Compose . d . fmap nt . getCompose)+              (fmap f . getCompose)+              (v <=< v' . getCompose) {-# INLINE weave #-}  @@ -100,7 +119,7 @@     => (∀ x. m x -> n x)     -> Union r m a     -> Union r n a-hoist f' (Union w (Yo e s nt f v)) = Union w $ Yo e s (f' . nt) f v+hoist f' (Union w (Weaving e s nt f v)) = Union w $ Weaving e s (f' . nt) f v {-# INLINE hoist #-}  @@ -178,7 +197,7 @@ ------------------------------------------------------------------------------ -- | Decompose a 'Union'. Either this union contains an effect @e@---the head -- of the @r@ list---or it doesn't.-decomp :: Union (e ': r) m a -> Either (Union r m a) (Yo e m a)+decomp :: Union (e ': r) m a -> Either (Union r m a) (Weaving e m a) decomp (Union p a) =   case p of     SZ   -> Right a@@ -188,7 +207,7 @@  ------------------------------------------------------------------------------ -- | Retrieve the last effect in a 'Union'.-extract :: Union '[e] m a -> Yo e m a+extract :: Union '[e] m a -> Weaving e m a extract (Union SZ a) = a extract _ = error "impossible" {-# INLINE extract #-}@@ -212,10 +231,10 @@ -- | Lift an effect @e@ into a 'Union' capable of holding it. inj :: forall r e a m. (Functor m , Member e r) => e m a -> Union r m a inj e = Union (finder @_ @r @e) $-  Yo e (Identity ())-       (fmap Identity . runIdentity)-       runIdentity-       (Just . runIdentity)+  Weaving e (Identity ())+            (fmap Identity . runIdentity)+            runIdentity+            (Just . runIdentity) {-# INLINE inj #-}  @@ -225,12 +244,11 @@      . ( Member e r        )     => Union r m a-    -> Maybe (Yo e m a)+    -> Maybe (Weaving e m a) prj (Union sn a) =-  let sm = finder @_ @r @e-   in case testEquality sn sm of-        Nothing -> Nothing-        Just Refl -> Just a+  case testEquality sn (finder @_ @r @e) of+    Nothing -> Nothing+    Just Refl -> Just a {-# INLINE prj #-}  @@ -239,7 +257,7 @@ -- 'Polysemy.Interpretation.reinterpret' function. decompCoerce     :: Union (e ': r) m a-    -> Either (Union (f ': r) m a) (Yo e m a)+    -> Either (Union (f ': r) m a) (Weaving e m a) decompCoerce (Union p a) =   case p of     SZ -> Right a@@ -263,3 +281,4 @@  instance LastMember end '[end] where   decompLast = Right+

@@ -64,8 +64,8 @@                      listToMaybe                      x       foldr cons nil z-    Right (Yo Empty _ _ _ _) -> empty-    Right (Yo (Choose ek) s _ y _) -> do+    Right (Weaving Empty _ _ _ _) -> empty+    Right (Weaving (Choose ek) s _ y _) -> do       z <- pure (ek False) <|> pure (ek True)       pure $ y $ z <$ s 

@@ -29,7 +29,7 @@ makeSem ''Reader  -asks :: Member (Reader i) r => (i -> j) -> Sem r j+asks :: forall i j r. Member (Reader i) r => (i -> j) -> Sem r j asks f = f <$> ask {-# INLINABLE asks #-} 

@@ -43,7 +43,7 @@ makeSem ''State  -gets :: Member (State s) r => (s -> a) -> Sem r a+gets :: forall s a r. Member (State s) r => (s -> a) -> Sem r a gets f = fmap f get {-# INLINABLE gets #-} @@ -106,8 +106,8 @@                                   $ S.runStateT m' s')                       (Just . snd)               $ hoist hoistStateIntoStateT x-    Right (Yo Get z _ y _)     -> fmap (y . (<$ z)) $ S.get-    Right (Yo (Put s) z _ y _) -> fmap (y . (<$ z)) $ S.put s+    Right (Weaving Get z _ y _)     -> fmap (y . (<$ z)) $ S.get+    Right (Weaving (Put s) z _ y _) -> fmap (y . (<$ z)) $ S.put s {-# INLINE hoistStateIntoStateT #-}  

@@ -8,6 +8,7 @@     -- * Actions   , tell   , listen+  , pass   , censor      -- * Interpretations@@ -27,10 +28,18 @@ data Writer o m a where   Tell   :: o -> Writer o m ()   Listen :: ∀ o m a. m a -> Writer o m (o, a)-  Censor :: (o -> o) -> m a -> Writer o m a+  Pass   :: m (o -> o, a) -> Writer o m a  makeSem ''Writer +------------------------------------------------------------------------------+-- | @since 0.7.0.0+censor :: Member (Writer o) r+       => (o -> o)+       -> Sem r a+       -> Sem r a+censor f m = pass (fmap (f ,) m)+{-# INLINE censor #-}  ------------------------------------------------------------------------------ -- | Transform an 'Output' effect into a 'Writer' effect.@@ -50,15 +59,19 @@ runWriter = runState mempty . reinterpretH   (\case       Tell o -> do-        modify (`mappend` o) >>= pureT+        modify (<> o) >>= pureT       Listen m -> do         mm <- runT m         -- TODO(sandy): this is stupid         (o, fa) <- raise $ runWriter mm+        modify (<> o)         pure $ fmap (o, ) fa-      Censor f m -> do+      Pass m -> do         mm <- runT m-        ~(o, a) <- raise $ runWriter mm-        modify (`mappend` f o)-        pure a+        (o, t) <- raise $ runWriter mm+        ins <- getInspectorT+        let f = maybe id fst (inspect ins t)+        modify (<> f o)+        pure (fmap snd t)   )+{-# INLINE runWriter #-}

@@ -2,9 +2,11 @@ {-# LANGUAGE DataKinds        #-} {-# LANGUAGE TemplateHaskell  #-} {-# LANGUAGE TypeApplications #-}-{-# OPTIONS_GHC -O2           #-} +{-# OPTIONS_GHC -O2 #-}+{-# OPTIONS_GHC -dsuppress-idinfo -dsuppress-coercions #-} + #if __GLASGOW_HASKELL__ < 804 {-# OPTIONS_GHC -fplugin=Test.Inspection.Plugin #-} #endif@@ -33,7 +35,7 @@ spec :: Spec spec = parallel $ do   describe "fusion" $ do-#if __GLASGOW_HASKELL__ >= 806+#if __GLASGOW_HASKELL__ >= 807     -- TODO: Investigate why this test fails mysteriously on GHC < 8.6     it "Union proofs should simplify" $ do       shouldSucceed $(inspectTest $ 'countDown `hasNoType` ''SNat)@@ -50,10 +52,19 @@       shouldSucceed $(inspectTest $ 'jank `doesNotUse` 'reinterpret)       shouldSucceed $(inspectTest $ 'jank `doesNotUse` 'hoist) -    it "who needs Semantic even?" $ do+    it "who needs Sem even?" $ do       shouldSucceed $(inspectTest $ 'countDown `doesNotUse` 'Sem)       shouldSucceed $(inspectTest $ 'jank `doesNotUse` 'Sem)       shouldSucceed $(inspectTest $ 'tryIt `doesNotUse` 'Sem)++#if __GLASGOW_HASKELL__ >= 807+    it "who needs Weaving even?" $ do+      shouldSucceed $(inspectTest $ 'jank `doesNotUse` 'Weaving)+      shouldSucceed $(inspectTest $ 'countDown `doesNotUse` 'Weaving)+#if __GLASGOW_HASKELL__ >= 810+      shouldSucceed $(inspectTest $ 'tryIt `doesNotUse` 'Weaving)+#endif+#endif   go :: Sem '[State Int] Int

@@ -0,0 +1,59 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+module WriterSpec where++import Test.Hspec++import Polysemy+import Polysemy.Error+import Polysemy.Writer++censor' :: forall e s a r+        . (Member (Error e) r, Member (Writer s) r)+        => (s -> s)+        -> Sem r a+        -> Sem r a+censor' f m = do+  res <- censor f $ fmap Right m `catch` (pure . Left)+  case res of+      Right res' -> return res'+      Left e -> throw (e :: e)++test1 :: (String, Either () ())+test1 =+    run+  . runWriter+  . runError $+  do+    tell "censoring"+    censor @String+      (drop 4)+      (tell " not applied" *> throw ())+    `catch`+      (\(_ :: ()) -> pure ())++test2 :: (String, Either () ())+test2 =+    run+  . runWriter+  . runError $+  do+    tell "censoring"+    censor' @() @String+      (drop 4)+      (tell " not applied" *> throw ())+    `catch`+      (\(_ :: ()) -> pure ())++test3 :: (String, (String, ()))+test3 = run . runWriter $ listen (tell "and hear")++spec :: Spec+spec = describe "writer" $ do+  it "should not censor" $ do+    test1 `shouldBe` ("censoring not applied", Right ())++  it "should censor" $ do+    test2 `shouldBe` ("censoring applied", Right ())++  it "should have a proper listen" $ do+    test3 `shouldBe` ("and hear", ("and hear", ()))