Fix broken higher order effects (#58)

* Fix a serious bug in interpretH and friends

* Spec to prove reader works now

package.yaml

@@ -50,7 +50,7 @@ flags:
     manual:      True
 
 library:
-  ghc-options: -O2 -Wall
+  ghc-options: -Wall
   source-dirs: src
   other-modules: Polysemy.Internal.PluginLookup
 

polysemy.cabal

@@ -4,7 +4,7 @@ cabal-version: 1.12
 --
 -- see: https://github.com/sol/hpack
 --
--- hash: 07720201673d182e7f285d795076b886bb48fb10b1704776922e431bf41b6c27
+-- hash: ba26fe189288c15d1156e0375dc7932bd3a9b7ace6c60e841135499f5f5a600b
 
 name:           polysemy
 version:        0.1.2.1
@@ -68,7 +68,7 @@ library
   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 @@ test-suite polysemy-test
   main-is: Main.hs
   other-modules:
       FusionSpec
+      HigherOrderSpec
       OutputSpec
       Paths_polysemy
   hs-source-dirs:

src/Polysemy/Internal.hs

@@ -15,6 +15,9 @@ module Polysemy.Internal
   , run
   , runM
   , raise
+  , raiseUnder
+  , raiseUnder2
+  , raiseUnder3
   , Lift (..)
   , usingSem
   , liftSem
@@ -253,6 +256,45 @@ raise_b = raise
 {-# NOINLINE raise_b #-}
 
 
+------------------------------------------------------------------------------
+-- | 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.

src/Polysemy/Internal/Combinators.hs

@@ -65,7 +65,7 @@ interpretH f (Sem m) = m $ \u ->
   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 @@ reinterpretH f (Sem m) = Sem $ \k -> m $ \u ->
   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 @@ reinterpret2H f (Sem m) = Sem $ \k -> m $ \u ->
   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 @@ reinterpret3H f (Sem m) = Sem $ \k -> m $ \u ->
   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 #-}
 

src/Polysemy/Internal/Union.hs

@@ -17,6 +17,9 @@ module Polysemy.Internal.Union
   -- * Building Unions
   , inj
   , weaken
+  , weakenUnder
+  , weakenUnder2
+  , weakenUnder3
   -- * Using Unions
   , decomp
   , prj
@@ -186,6 +189,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 #-}
+
 
 ------------------------------------------------------------------------------
 -- | Lift an effect @e@ into a 'Union' capable of holding it.

test/HigherOrderSpec.hs

@@ -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!"
+