From c1ccde89b67605300d0a93c6b85e3fe6b40172f0 Mon Sep 17 00:00:00 2001 From: Colin Wahl Date: Tue, 12 Feb 2019 21:13:50 -0800 Subject: [PATCH] split CHOOSE into two different effects: CHOOSE and EMPTY --- src/Run.purs | 11 +++++++---- src/Run/Choose.purs | 9 ++------- src/Run/Empty.purs | 25 +++++++++++++++++++++++++ src/Run/Internal.purs | 15 +++++++++++++-- test/Main.purs | 6 +++++- 5 files changed, 52 insertions(+), 14 deletions(-) create mode 100644 src/Run/Empty.purs diff --git a/src/Run.purs b/src/Run.purs index 710c0be..0c86682 100644 --- a/src/Run.purs +++ b/src/Run.purs @@ -47,7 +47,7 @@ import Data.Symbol (SProxy(..)) as Exports import Data.Symbol (SProxy(..), class IsSymbol) import Data.Tuple (Tuple(..), curry, uncurry) import Partial.Unsafe (unsafeCrashWith) -import Run.Internal (_choose, CHOOSE, Choose(..), toRows, fromRows) +import Run.Internal (_choose, CHOOSE, Choose(..), _empty, EMPTY, Empty(..), toRows, fromRows) import Type.Equality (class TypeEquals) import Prim.Row as Row import Type.Row (RProxy) @@ -345,10 +345,13 @@ instance runMonadAff ∷ (TypeEquals (RProxy r1) (RProxy (aff ∷ AFF, effect liftChoose ∷ ∀ r a. Choose a → Run (choose ∷ CHOOSE | r) a liftChoose = lift _choose +liftEmpty :: forall r a. Empty a -> Run (empty :: EMPTY | r) a +liftEmpty = lift _empty + instance runAlt ∷ (TypeEquals (RProxy r1) (RProxy (choose ∷ CHOOSE | r2))) ⇒ Alt (Run r1) where alt a b = fromRows $ liftChoose (Alt identity) >>= if _ then toRows a else toRows b -instance runPlus ∷ (TypeEquals (RProxy r1) (RProxy (choose ∷ CHOOSE | r2))) ⇒ Plus (Run r1) where - empty = fromRows $ liftChoose Empty +instance runPlus ∷ (TypeEquals (RProxy r1) (RProxy (choose :: CHOOSE, empty ∷ EMPTY | r2))) ⇒ Plus (Run r1) where + empty = fromRows $ liftEmpty Empty -instance runAlternative ∷ (TypeEquals (RProxy r1) (RProxy (choose ∷ CHOOSE | r2))) ⇒ Alternative (Run r1) +instance runAlternative ∷ (TypeEquals (RProxy r1) (RProxy (choose ∷ CHOOSE, empty :: EMPTY | r2))) ⇒ Alternative (Run r1) diff --git a/src/Run/Choose.purs b/src/Run/Choose.purs index 8f56280..d3a2195 100644 --- a/src/Run/Choose.purs +++ b/src/Run/Choose.purs @@ -1,6 +1,5 @@ module Run.Choose ( liftChoose - , cempty , calt , runChoose , module Run.Internal @@ -8,7 +7,7 @@ module Run.Choose import Prelude -import Control.Alternative (class Alternative, alt, empty ) +import Control.Alt (class Alt, alt) import Data.Either (Either(..)) import Run (Run) import Run as Run @@ -17,20 +16,16 @@ import Run.Internal (Choose(..), CHOOSE, _choose) liftChoose ∷ ∀ r a. Choose a → Run (choose ∷ CHOOSE | r) a liftChoose = Run.lift _choose -cempty ∷ ∀ r a. Run (choose ∷ CHOOSE | r) a -cempty = empty - calt ∷ ∀ r a. Run (choose ∷ CHOOSE | r) a → Run (choose ∷ CHOOSE | r) a → Run (choose ∷ CHOOSE | r) a calt = alt -runChoose ∷ ∀ f a r. Alternative f ⇒ Run (choose ∷ CHOOSE | r) a → Run r (f a) +runChoose ∷ ∀ f a r. Alt f => Applicative f ⇒ Run (choose ∷ CHOOSE | r) a → Run r (f a) runChoose = loop where handle = Run.on _choose Left Right loop r = case Run.peel r of Left a → case handle a of Left a' → case a' of - Empty → pure empty Alt k → do x ← loop (k true) y ← loop (k false) diff --git a/src/Run/Empty.purs b/src/Run/Empty.purs new file mode 100644 index 0000000..4e7d907 --- /dev/null +++ b/src/Run/Empty.purs @@ -0,0 +1,25 @@ +module Run.Empty where + +import Prelude + +import Control.Plus (class Plus, empty) +import Data.Either (Either(..)) +import Run (Run) +import Run as Run +import Run.Internal (Empty(..), EMPTY, _empty) + +liftEmpty :: forall r a. Empty a -> Run (empty :: EMPTY | r) a +liftEmpty = Run.lift _empty + +runEmpty :: forall f a r. Applicative f => Plus f => Run (empty :: EMPTY | r) a -> Run r (f a) +runEmpty = loop + where + handle = Run.on _empty Left Right + loop r = case Run.peel r of + Left a -> case handle a of + Left a' -> case a' of + Empty -> pure empty + Right a' -> + Run.send a' >>= loop + Right a -> + pure (pure a) diff --git a/src/Run/Internal.purs b/src/Run/Internal.purs index cb98a74..f0e7845 100644 --- a/src/Run/Internal.purs +++ b/src/Run/Internal.purs @@ -2,6 +2,9 @@ module Run.Internal ( Choose(..) , CHOOSE , _choose + , Empty(..) + , EMPTY + , _empty , toRows , fromRows ) where @@ -14,8 +17,7 @@ import Type.Row (RProxy) import Unsafe.Coerce (unsafeCoerce) data Choose a - = Empty - | Alt (Boolean → a) + = Alt (Boolean → a) derive instance functorChoose ∷ Functor Choose @@ -24,6 +26,15 @@ type CHOOSE = FProxy Choose _choose ∷ SProxy "choose" _choose = SProxy +data Empty a = Empty + +derive instance functorEmpty :: Functor Empty + +type EMPTY = FProxy Empty + +_empty :: SProxy "empty" +_empty = SProxy + toRows ∷ ∀ f r1 r2 a . TypeEquals (RProxy r1) (RProxy r2) diff --git a/test/Main.purs b/test/Main.purs index f1f9002..4909136 100644 --- a/test/Main.purs +++ b/test/Main.purs @@ -10,7 +10,9 @@ import Effect (Effect) import Effect.Console (logShow, log) import Run (EFFECT, FProxy, Run, SProxy(..), lift, liftEffect, on, extract, runBaseEffect, run, send) import Run.Choose (CHOOSE, runChoose) +import Run.Empty (runEmpty) import Run.Except (EXCEPT, catch, runExcept, runExceptAt, throw, throwAt) +import Run.Internal (EMPTY) import Run.Reader (READER, ask, runReader) import Run.State (STATE, get, gets, modify, put, putAt, runState, runStateAt) import Run.Writer (WRITER, runWriter, tell) @@ -91,7 +93,7 @@ yesProgram = do whileM_ mb ma = flip tailRecM unit \a → mb >>= if _ then ma $> Loop unit else pure $ Done unit -chooseProgram ∷ ∀ r. Run (choose ∷ CHOOSE, effect ∷ EFFECT | r) Int +chooseProgram ∷ ∀ r. Run (choose ∷ CHOOSE, effect :: EFFECT, empty :: EMPTY | r) Int chooseProgram = do n ← oneOfMap pure [1, 2, 3, 4, 5] liftEffect $ log $ show n @@ -145,6 +147,8 @@ main = do as ← chooseProgram # runChoose + # runEmpty + # map join # runBaseEffect logShow (as ∷ Array Int)