Select handler

test/properties/Accum.hs

@@ -14,6 +14,7 @@ module Accum
     AccumArb (..),
     accumLaws,
     accumLawsCont,
+    accumLawsSelect,
   )
 where
 
@@ -71,6 +72,81 @@ newtype AccumArb (w :: Type) (a :: Type)
 runAccumArb :: AccumArb w a -> w -> (a, w)
 runAccumArb (AccumArb f) = f
 
+accumLawsSelect ::
+  forall (m :: Type -> Type) (t :: Type).
+  (MonadAccum M m, Typeable m, Arbitrary t, Show t) =>
+  (forall (a :: Type). t -> m a -> (a -> AccumArb M B) -> AccumArb M a) ->
+  TestTree
+accumLawsSelect lowerSelect =
+  testProperties
+    testName
+    [ ("look *> look = look", lookLookProp),
+      ("add mempty = pure ()", addMemptyProp),
+      ("add x *> add y = add (x <> y)", addAddProp),
+      ("add x *> look = look >>= \\w -> add x $> w <> x", addLookProp),
+      ("accum (const (x, mempty)) = pure x", accumPureProp),
+      ("accum f *> accum g law (too long)", accumFGProp),
+      ("look = accum $ \\acc -> (acc, mempty)", lookAccumProp),
+      ("add x = accum $ \\acc -> ((), x)", addAccumProp),
+      ("accum f = look >>= \\acc -> let (res, v) = f acc in add v $> res", accumAddProp)
+    ]
+  where
+    testName :: String
+    testName = "MonadAccum laws for " <> typeName @(m A)
+    addAccumProp :: Property
+    addAccumProp = theNeedful $ \(w, arg, x, Blind f) ->
+      let lhs = lowerSelect arg (add x) f
+          rhs = lowerSelect arg (accum $ const ((), x)) f
+       in runAccumArb lhs w === runAccumArb rhs w
+    accumAddProp :: Property
+    accumAddProp = theNeedful $ \(w, arg, Blind (f :: M -> (A, M)), Blind g) ->
+      let lhs = lowerSelect arg (accum f) g
+          rhs = lowerSelect arg (look >>= \acc -> let (res, v) = f acc in add v $> res) g
+       in runAccumArb lhs w === runAccumArb rhs w
+    lookAccumProp :: Property
+    lookAccumProp = theNeedful $ \(w, arg, Blind f) ->
+      let lhs = lowerSelect arg look f
+          rhs = lowerSelect arg (accum (,mempty)) f
+       in runAccumArb lhs w === runAccumArb rhs w
+    lookLookProp :: Property
+    lookLookProp = theNeedful $ \(w, arg, Blind f) ->
+      let lhs = lowerSelect arg look f
+          rhs = lowerSelect arg (look *> look) f
+       in runAccumArb lhs w === runAccumArb rhs w
+    addMemptyProp :: Property
+    addMemptyProp = theNeedful $ \(w, arg, Blind f) ->
+      let lhs = lowerSelect arg (add mempty) f
+          rhs = lowerSelect arg (pure ()) f
+       in runAccumArb lhs w === runAccumArb rhs w
+    addAddProp :: Property
+    addAddProp = theNeedful $ \(w, arg, x, y, Blind f) ->
+      let lhs = lowerSelect arg (add x *> add y) f
+          rhs = lowerSelect arg (add (x <> y)) f
+       in runAccumArb lhs w === runAccumArb rhs w
+    addLookProp :: Property
+    addLookProp = theNeedful $ \(w, arg, x, Blind f) ->
+      let lhs = lowerSelect arg (add x *> look) f
+          rhs = lowerSelect arg (look >>= \w' -> add x $> w' <> x) f
+       in runAccumArb lhs w === runAccumArb rhs w
+    accumPureProp :: Property
+    accumPureProp = theNeedful $ \(w, arg, x :: A, Blind f) ->
+      let lhs = lowerSelect arg (accum (const (x, mempty))) f
+          rhs = lowerSelect arg (pure x) f
+       in runAccumArb lhs w === runAccumArb rhs w
+    accumFGProp :: Property
+    accumFGProp = theNeedful $ \(w', arg, Blind (f :: M -> (A, M)), Blind (g :: M -> (M, M)), Blind h) ->
+      let lhs = lowerSelect arg (accum f *> accum g) h
+          rhs =
+            lowerSelect
+              arg
+              ( accum $ \acc ->
+                  let (_, v) = f acc
+                      (res, w) = g (acc <> v)
+                   in (res, v <> w)
+              )
+              h
+       in runAccumArb lhs w' === runAccumArb rhs w'
+
 accumLawsCont ::
   forall (m :: Type -> Type) (t :: Type).
   (MonadAccum M m, Typeable m, Arbitrary t, Show t) =>

test/properties/Main.hs

@@ -4,7 +4,14 @@
 
 module Main (main) where
 
-import Accum (AccumArb (AccumArb), M, N, accumLaws, accumLawsCont)
+import Accum
+  ( AccumArb (AccumArb),
+    M,
+    N,
+    accumLaws,
+    accumLawsCont,
+    accumLawsSelect,
+  )
 import Control.Monad.Trans.Accum (Accum, AccumT (AccumT), accum, runAccum)
 import Control.Monad.Trans.Cont (ContT, runContT)
 import Control.Monad.Trans.Except (ExceptT, runExceptT)
@@ -14,6 +21,7 @@ import qualified Control.Monad.Trans.RWS.CPS as RWSCPS
 import qualified Control.Monad.Trans.RWS.Lazy as RWSLazy
 import qualified Control.Monad.Trans.RWS.Strict as RWSStrict
 import Control.Monad.Trans.Reader (ReaderT, runReaderT)
+import Control.Monad.Trans.Select (SelectT, runSelectT)
 import qualified Control.Monad.Trans.State.Lazy as StateLazy
 import qualified Control.Monad.Trans.State.Strict as StateStrict
 import qualified Control.Monad.Trans.Writer.CPS as WriterCPS
@@ -45,7 +53,8 @@ main = do
           accumLaws lowerWriterLazy,
           accumLaws lowerWriterStrict,
           accumLaws lowerWriterCPS,
-          accumLawsCont lowerCont
+          accumLawsCont lowerCont,
+          accumLawsSelect lowerSelect
         ]
     ]
   where
@@ -54,6 +63,15 @@ main = do
 
 -- Lowerings
 
+lowerSelect ::
+  forall (a :: Type).
+  () ->
+  SelectT B (Accum M) a ->
+  (a -> AccumArb M B) ->
+  AccumArb M a
+lowerSelect _ comp handler =
+  demote . runSelectT comp $ (promote . handler)
+
 lowerCont ::
   forall (a :: Type).
   () ->