polysemy 0.1.2.1 → 0.2.0.0

raw patch · 9 files changed

+118/−89 lines, 9 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• ChangeLog.md +13/−0
• polysemy.cabal +4/−3
• src/Polysemy.hs +1/−3
• src/Polysemy/Internal.hs +49/−2
• src/Polysemy/Internal/Combinators.hs +4/−4
• src/Polysemy/Internal/CustomErrors.hs +2/−1
• src/Polysemy/Internal/TH/Performance.hs +5/−76
• src/Polysemy/Internal/Union.hs +24/−0
• test/HigherOrderSpec.hs +16/−0

@@ -1,5 +1,11 @@ # Changelog for polysemy +## 0.2.0.0 (2019-05-23)++- Fixed a serious bug in `interpretH` and friends, where higher-order effects+    would always be run with the current interpreter.+- Lower precedence of `.@` and `.@@` to 8, from 9+ ## 0.1.2.1 (2019-05-18)  - Give explicit package bounds for dependencies@@ -27,4 +33,11 @@ - Initial release  ## Unreleased changes++- **NEEDS MAJOR REVISION**: no longer require `inlineRecursiveCalls` --- the+    plugin does it automatically when compiling with `-O2`+- Deprecated `inlineRecursiveCalls`; slated for removal in the next version+- **NEEDS MAJOR PLUGIN REVISION**: plugin now automatically inlines recursive+    calls+ 

@@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: 07720201673d182e7f285d795076b886bb48fb10b1704776922e431bf41b6c27+-- hash: 9a2044113434528f0539fb410b356387676cc468eefb618a666c1246379b43da  name:           polysemy-version:        0.1.2.1+version:        0.2.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@@ -68,7 +68,7 @@   hs-source-dirs:       src   default-extensions: DataKinds DeriveFunctor FlexibleContexts GADTs LambdaCase PolyKinds RankNTypes ScopedTypeVariables StandaloneDeriving TypeApplications TypeOperators TypeFamilies UnicodeSyntax-  ghc-options: -O2 -Wall+  ghc-options: -Wall   build-depends:       base >=4.7 && <5     , mtl >=2.2.2 && <3@@ -89,6 +89,7 @@   main-is: Main.hs   other-modules:       FusionSpec+      HigherOrderSpec       OutputSpec       Paths_polysemy   hs-source-dirs:

@@ -88,9 +88,6 @@   , reinterpret2H   , reinterpret3H -    -- * Improving Performance for Interpreters-  , inlineRecursiveCalls-     -- * Composing IO-based Interpreters   , (.@)   , (.@@)@@ -119,6 +116,7 @@   , runSemantic   , makeSemantic   , makeSemantic_+  , inlineRecursiveCalls   ) where  import Polysemy.Internal

@@ -15,6 +15,9 @@   , run   , runM   , raise+  , raiseUnder+  , raiseUnder2+  , raiseUnder3   , Lift (..)   , usingSem   , liftSem@@ -254,6 +257,45 @@   ------------------------------------------------------------------------------+-- | Like 'raise', but introduces a new effect uunderneath the head of the+-- list.+raiseUnder :: ∀ e2 e1 r a. Sem (e1 ': r) a -> Sem (e1 ': e2 ': r) a+raiseUnder = hoistSem $ hoist raiseUnder_b . weakenUnder+{-# INLINE raiseUnder #-}+++raiseUnder_b :: Sem (e1 ': r) a -> Sem (e1 ': e2 ': r) a+raiseUnder_b = raiseUnder+{-# NOINLINE raiseUnder_b #-}+++------------------------------------------------------------------------------+-- | Like 'raise', but introduces two new effects uunderneath the head of the+-- list.+raiseUnder2 :: ∀ e2 e3 e1 r a. Sem (e1 ': r) a -> Sem (e1 ': e2 ': e3 ': r) a+raiseUnder2 = hoistSem $ hoist raiseUnder2_b . weakenUnder2+{-# INLINE raiseUnder2 #-}+++raiseUnder2_b :: Sem (e1 ': r) a -> Sem (e1 ': e2 ': e3 ': r) a+raiseUnder2_b = raiseUnder2+{-# NOINLINE raiseUnder2_b #-}+++------------------------------------------------------------------------------+-- | Like 'raise', but introduces two new effects uunderneath the head of the+-- list.+raiseUnder3 :: ∀ e2 e3 e4 e1 r a. Sem (e1 ': r) a -> Sem (e1 ': e2 ': e3 ': e4 ': r) a+raiseUnder3 = hoistSem $ hoist raiseUnder3_b . weakenUnder3+{-# INLINE raiseUnder3 #-}+++raiseUnder3_b :: Sem (e1 ': r) a -> Sem (e1 ': e2 ': e3 ': e4 ': r) a+raiseUnder3_b = raiseUnder3+{-# NOINLINE raiseUnder3_b #-}+++------------------------------------------------------------------------------ -- | Lift an effect into a 'Sem'. This is used primarily via -- 'Polysemy.makeSem' to implement smart constructors. send :: Member e r => e (Sem r) a -> Sem r a@@ -311,6 +353,11 @@ -- -- The parentheses here are important; without them you'll run into operator -- precedence errors.+--+-- __Warning:__ This combinator will __duplicate work__ that is intended to be+-- just for initialization. This can result in rather surprising behavior. For+-- a version of '.@' that won't duplicate work, see the @.\@!@ operator in+-- <http://hackage.haskell.org/package/polysemy-zoo/docs/Polysemy-IdempotentLowering.html polysemy-zoo>. (.@)     :: Monad m     => (∀ x. Sem r x -> m x)@@ -321,7 +368,7 @@     -> Sem (e ': r) z     -> m z f .@ g = f . g f-infixl 9 .@+infixl 8 .@   ------------------------------------------------------------------------------@@ -337,5 +384,5 @@     -> Sem (e ': r) z     -> m (f z) f .@@ g = f . g f-infixl 9 .@@+infixl 8 .@@ 

@@ -65,7 +65,7 @@   case decomp u of     Left  x -> liftSem $ hoist (interpretH_b f) x     Right (Yo e s d y) -> do-      a <- runTactics s (raise . interpretH_b f . d) (f e)+      a <- runTactics s d (f e)       pure $ y a {-# INLINE interpretH #-} @@ -142,7 +142,7 @@   case decompCoerce u of     Left x  -> k $ hoist (reinterpretH_b f) $ x     Right (Yo e s d y) -> do-      a <- usingSem k $ runTactics s (raise . reinterpretH_b f . d) $ f e+      a <- usingSem k $ runTactics s (raiseUnder . d) $ f e       pure $ y a {-# INLINE[3] reinterpretH #-} -- TODO(sandy): Make this fuse in with 'stateful' directly.@@ -177,7 +177,7 @@   case decompCoerce u of     Left x  -> k $ weaken $ hoist (reinterpret2H_b f) $ x     Right (Yo e s d y) -> do-      a <- usingSem k $ runTactics s (raise . reinterpret2H_b f . d) $ f e+      a <- usingSem k $ runTactics s (raiseUnder2 . d) $ f e       pure $ y a {-# INLINE[3] reinterpret2H #-} @@ -207,7 +207,7 @@   case decompCoerce u of     Left x  -> k . weaken . weaken . hoist (reinterpret3H_b f) $ x     Right (Yo e s d y) -> do-      a <- usingSem k $ runTactics s (raise . reinterpret3H_b f . d) $ f e+      a <- usingSem k $ runTactics s (raiseUnder3 . d) $ f e       pure $ y a {-# INLINE[3] reinterpret3H #-} 

@@ -51,7 +51,8 @@     ':$$: 'Text "  add a type application to specify"     ':$$: 'Text "    "     ':<>: PrettyPrint vs-    ':<>: 'Text " directly"+    ':<>: 'Text " directly, or activate polysemy-plugin which"+    ':$$: 'Text "      can usually infer the type correctly."         )  type family PrettyPrint (vs :: [k]) where

@@ -1,86 +1,15 @@-{-# LANGUAGE BlockArguments  #-}-{-# LANGUAGE TemplateHaskell #-}- {-# OPTIONS_HADDOCK not-home #-}  module Polysemy.Internal.TH.Performance   ( inlineRecursiveCalls   ) where -import Control.Monad-import Data.Bool-import Data.Maybe (maybeToList, mapMaybe)-import Data.Monoid (Any (..))-import Generics.SYB import Language.Haskell.TH ---------------------------------------------------------------------------------- | GHC has a really hard time inlining recursive calls---such as those used in--- interpreters for higher-order effects. This can have disastrous repercussions--- for your performance.------ Fortunately there's a solution, but it's ugly boilerplate. You can enable--- @-XTemplateHaskell@ and use 'inlineRecursiveCalls' to convince GHC to make--- these functions fast again.------ @--- 'inlineRecursiveCalls' [d|---   'Polysemy.Reader.runReader' :: i -> 'Polysemy.Sem' ('Polysemy.Reader.Reader' i ': r) a -> 'Polysemy.Sem' r a---   'Polysemy.Reader.runReader' i = 'Polysemy.interpretH' $ \\case---     'Polysemy.Reader.Ask' -> 'Polysemy.pureT' i---     'Polysemy.Reader.Local' f m -> do---       mm <- 'Polysemy.runT' m---       'Polysemy.raise' $ 'Polysemy.Reader.runReader' (f i) mm---   |]--- @-inlineRecursiveCalls :: Q [Dec] -> Q [Dec]-inlineRecursiveCalls m = do-  decs <- m-  let types   = mapMaybe getType decs-      inlines = mapMaybe hasInline decs-  fmap join $ traverse (loopbreaker types inlines) decs---isRecursive :: Name -> [Clause] -> Bool-isRecursive n cs =-  getAny $-    everything-      (<>)-      (mkQ (Any False) $ withRec (const $ Any False) (Any True) n)-      cs---withRec :: (Exp -> a) -> a -> Name -> Exp -> a-withRec unmatched matched n = \case-  VarE n' | n == n' -> matched-  a                 -> unmatched a---getType :: Dec -> Maybe (Name, Type)-getType (SigD n t) = Just (n, t)-getType _ = Nothing---hasInline :: Dec -> Maybe (Name)-hasInline (PragmaD (InlineP n Inline _ _)) = Just n-hasInline _ = Nothing-+{-# DEPRECATED inlineRecursiveCalls+      "Enabling polysemy-plugin now automatically inlines recursive calls"+      #-} -loopbreaker :: [(Name, Type)] -> [Name] -> Dec -> Q [Dec]-loopbreaker types inlined (FunD n cs)-  | isRecursive n cs = do-      nLB <- newName $ mconcat-               [ "___"-               , nameBase n-               , "___loop_breaker"-               ]-      pure $-        [ FunD n $ everywhere (mkT $ withRec id (VarE nLB) n) cs-        , FunD nLB [Clause [] (NormalB $ VarE n) []]-        , PragmaD $ InlineP nLB NoInline FunLike AllPhases-        ] ++ maybeToList (fmap (SigD nLB) $ lookup n types)-          ++ bool [PragmaD $ InlineP n Inline FunLike AllPhases]-                  []-                  (elem n inlined)-loopbreaker _ _ z = pure [z]+inlineRecursiveCalls :: Q [Dec] -> Q [Dec]+inlineRecursiveCalls = id 

@@ -17,6 +17,9 @@   -- * Building Unions   , inj   , weaken+  , weakenUnder+  , weakenUnder2+  , weakenUnder3   -- * Using Unions   , decomp   , prj@@ -185,6 +188,27 @@ weaken :: Union r m a -> Union (e ': r) m a weaken (Union n a) = Union (SS n) a {-# INLINE weaken #-}++------------------------------------------------------------------------------+-- | Like 'weaken', but introduces a new effect under the top of the stack.+weakenUnder :: Union (e1 ': r) m a -> Union (e1 ': e2 ': r) m a+weakenUnder (Union SZ a) = Union SZ a+weakenUnder (Union (SS n) a) = Union (SS (SS n)) a+{-# INLINE weakenUnder #-}++------------------------------------------------------------------------------+-- | Like 'weaken', but introduces a new effect under the top of the stack.+weakenUnder2 :: Union (e1 ': r) m a -> Union (e1 ': e2 ': e3 ': r) m a+weakenUnder2 (Union SZ a) = Union SZ a+weakenUnder2 (Union (SS n) a) = Union (SS (SS (SS n))) a+{-# INLINE weakenUnder2 #-}++------------------------------------------------------------------------------+-- | Like 'weaken', but introduces a new effect under the top of the stack.+weakenUnder3 :: Union (e1 ': r) m a -> Union (e1 ': e2 ': e3 ': e4 ': r) m a+weakenUnder3 (Union SZ a) = Union SZ a+weakenUnder3 (Union (SS n) a) = Union (SS (SS (SS (SS n)))) a+{-# INLINE weakenUnder3 #-}   ------------------------------------------------------------------------------

@@ -0,0 +1,16 @@+module HigherOrderSpec where++import Polysemy+import Polysemy.Reader+import Test.Hspec+++spec :: Spec+spec = describe "Reader local" $ do+  it "should nest with itself" $ do+    let foo = run . runReader "hello" $ do+                local (++ " world") $ do+                  local (++ "!") $ do+                    ask+    foo `shouldBe` "hello world!"+