WIP: Implement IO safely

src/Control/Ev/Ctl.hs

@@ -17,14 +17,14 @@ module Control.Ev.Ctl(
           , markerEq     -- :: Marker a -> Marker b -> Bool
 
           -- * Control monad
-          , Ctl(Pure)    -- multi-prompt control monad
+          , Ctl          -- multi-prompt control monad
           , runCtl       -- run the control monad       :: Ctl a -> a
           , prompt       -- install a multi-prompt      :: (Marker a -> Ctl a) -> Ctl a
           , yield        -- yield to a specific prompt  :: Marker ans -> ((b -> Ctl ans) -> Ctl ans) -> Ctl b
 
           -- * Unsafe primitives for "Control.Ev.Eff"
-          , unsafeIO            -- lift IO into Ctl        :: IO a -> Ctl a
-          , unsafePromptIORef   -- IORef that gets restored per resumption
+          , safeIO            -- lift IO into Ctl        :: IO a -> Ctl a
+          , safePromptIORef   -- IORef that gets restored per resumption
           ) where
 
 import Prelude hiding (read,flip)
@@ -78,51 +78,55 @@ freshMarker f
 with existentials `ans` and `b`: where `ans` is the answer type, i.e. the type of the handler/prompt context,
 and `b` the result type of the operation.
 -}
-data Ctl a = Pure { result :: !a }  -- ^ Pure results (only exported for use in the "Control.Ev.Eff" module)
-           | forall ans b.
-             Yield{ marker :: !(Marker ans),                 -- ^ prompt marker to yield to (in type context `::ans`)
-                    op     :: !((b -> Ctl ans) -> Ctl ans),  -- ^ the final action, just needs the resumption (:: b -> Ctl ans) to be evaluated.
-                    cont   :: !(b -> Ctl a)                  -- ^ the (partially) build up resumption; `(b -> Ctl a) :~: (b -> Ctl ans)` by the time we reach the prompt
-                  }
+newtype Ctl a = Ctl { unCtl :: IO (Ctl' a) }
+
+data Ctl' a = Pure { result :: !a }  -- ^ Pure results
+            | forall ans b.
+              Yield{ marker :: !(Marker ans),                 -- ^ prompt marker to yield to (in type context `::ans`)
+                     op     :: !((b -> Ctl ans) -> Ctl ans),  -- ^ the final action, just needs the resumption (:: b -> Ctl ans) to be evaluated.
+                     cont   :: !(b -> Ctl a)                  -- ^ the (partially) build up resumption; `(b -> Ctl a) :~: (b -> Ctl ans)` by the time we reach the prompt
+                   }
 
 -- | @yield m op@ yields to a specific marker and calls @op@ in that context
 -- with a /resumption/ @k :: b -> Ctl ans@ that resumes at the original call-site
 -- with a result of type @b@. If the marker is no longer in the evaluation context,
 -- (i.e. it escaped outside its prompt) the `yield` fails with an @"unhandled operation"@ error.
 {-# INLINE yield #-}
 yield :: Marker ans -> ((b -> Ctl ans) -> Ctl ans) -> Ctl b
-yield m op  = Yield m op Pure
+yield m op  = Ctl (pure (Yield m op (Ctl . pure . Pure)))
 
 {-# INLINE kcompose #-}
 kcompose :: (b -> Ctl c) -> (a -> Ctl b) -> a -> Ctl c      -- Kleisli composition
-kcompose g f x = case (f x) of
-                   Pure x -> g x
-                   Yield m op cont -> Yield m op (g `kcompose` cont)
+kcompose g f x = Ctl $ unCtl (f x) >>= \x' -> case x' of
+                   Pure x -> unCtl (g x)
+                   Yield m op cont -> pure (Yield m op (g `kcompose` cont))
 
 {-# INLINE bind #-}
 bind :: Ctl a -> (a -> Ctl b) -> Ctl b
-bind (Pure x) f           = f x
-bind (Yield m op cont) f  = Yield m op (f `kcompose` cont)  -- keep yielding with an extended continuation
+bind (Ctl x) f = Ctl $ x >>= \x' -> case x' of
+  (Pure x)          -> unCtl (f x)
+  (Yield m op cont) -> pure (Yield m op (f `kcompose` cont))  -- keep yielding with an extended continuation
 
 instance Functor Ctl where
   fmap  = liftM
 instance Applicative Ctl where
   pure  = return
   (<*>) = ap
 instance Monad Ctl where
-  return x  = Pure x
+  return x  = Ctl (pure (Pure x))
   e >>= f   = bind e f
 
 
 -- install a prompt with a unique marker (and handle yields to it)
 {-# INLINE mprompt #-}
 mprompt :: Marker a -> Ctl a -> Ctl a
-mprompt m p@(Pure _) = p
-mprompt m (Yield n op cont)
-  = let cont' x = mprompt m (cont x) in  -- extend the continuation with our own prompt
+mprompt m x = Ctl $ unCtl x >>= \x' -> case x' of
+  p@(Pure _) -> pure p
+  (Yield n op cont) ->
+    let cont' x = mprompt m (cont x) in  -- extend the continuation with our own prompt
     case mmatch m n of
-      Nothing   -> Yield n op cont'   -- keep yielding (but with the extended continuation)
-      Just Refl -> op cont'           -- found our prompt, invoke `op`.
+      Nothing   -> pure (Yield n op cont')   -- keep yielding (but with the extended continuation)
+      Just Refl -> unCtl (op cont')           -- found our prompt, invoke `op`.
                    -- Note: `Refl` proves `a ~ ans` (the existential `ans` in Yield)
 
 -- | Install a /prompt/ with a specific prompt `Marker` to which one can `yield`.
@@ -138,34 +142,33 @@ prompt action
 -- | Run a control monad. This may fail with an @"unhandled operation"@ error if 
 -- there is a `yield` to a marker that escaped its prompt scope.
 runCtl :: Ctl a -> a
-runCtl (Pure x)      = x
-runCtl (Yield _ _ _) = error "Unhandled operation"  -- only if marker escapes the scope of the prompt
+runCtl x = unsafePerformIO $ unCtl x >>= \x' -> case x' of
+  Pure x -> pure x
+  Yield{} -> error "Unhandled operation"  -- only if marker escapes the scope of the prompt
 
 
 -------------------------------------------------------
 -- IORef's
 -------------------------------------------------------
 
 -- | Unsafe `IO` in the `Ctl` monad.
-{-# INLINE unsafeIO #-}
-unsafeIO :: IO a -> Ctl a
-unsafeIO io = let x = unsafeInlinePrim io in seq x (Pure x)
+{-# INLINE safeIO #-}
+safeIO :: IO a -> Ctl a
+safeIO io = Ctl (Pure <$> io)
 
 -- A special prompt that saves and restores state per resumption
 mpromptIORef :: IORef a -> Ctl b -> Ctl b
-mpromptIORef r action
-  = case action of
-      p@(Pure _) -> p
-      Yield m op cont
-        -> do val <- unsafeIO (readIORef r)                 -- save current value on yielding
-              let cont' x = do unsafeIO (writeIORef r val)  -- restore saved value on resume
-                               mpromptIORef r (cont x)
-              Yield m op cont'
+mpromptIORef r action = Ctl $ unCtl action >>= \x -> case x of
+  p@(Pure _) -> pure p
+  Yield m op cont -> do
+    val <- readIORef r                       -- save current value on yielding
+    let cont' x = Ctl $ do writeIORef r val  -- restore saved value on resume
+                           unCtl (mpromptIORef r (cont x))
+    pure $ Yield m op cont'
 
 -- | Create an `IORef` connected to a prompt. The value of
 -- the `IORef` is saved and restored through resumptions.
-unsafePromptIORef :: a -> (Marker b -> IORef a -> Ctl b) -> Ctl b
-unsafePromptIORef init action
-  = freshMarker $ \m ->
-    do r <- unsafeIO (newIORef init)
-       mpromptIORef r (action m r)
+safePromptIORef :: a -> (Marker b -> IORef a -> Ctl b) -> Ctl b
+safePromptIORef init action = freshMarker $ \m -> do
+  r <- safeIO (newIORef init)
+  mpromptIORef r (action m r)

src/Control/Ev/Eff.hs

@@ -374,17 +374,17 @@ newtype Local a e ans = Local (IORef a)
 -- | Get the value of the local state.
 {-# INLINE lget #-}
 lget :: Local a e ans -> Op () a e ans
-lget (Local r) = Op (\m ctx x -> unsafeIO (seq x $ readIORef r))
+lget (Local r) = Op (\m ctx x -> safeIO (seq x $ readIORef r))
 
 -- | Set the value of the local state.
 {-# INLINE lput #-}
 lput :: Local a e ans -> Op a () e ans
-lput (Local r) = Op (\m ctx x -> unsafeIO (writeIORef r x))
+lput (Local r) = Op (\m ctx x -> safeIO (writeIORef r x))
 
 -- | Update the value of the local state.
 {-# INLINE lmodify #-}
 lmodify :: Local a e ans -> Op (a -> a) () e ans
-lmodify (Local r) = Op (\m ctx f -> unsafeIO (do{ x <- readIORef r; writeIORef r $! (f x) }))
+lmodify (Local r) = Op (\m ctx f -> safeIO (do{ x <- readIORef r; writeIORef r $! (f x) }))
 
 -- | Get the value of the local state if it is the top handler.
 localGet :: Eff (Local a :* e) a
@@ -403,9 +403,9 @@ localModify f = perform lmodify f
 {-# INLINE localRet #-}
 localRet :: a -> (ans -> a -> b) -> Eff (Local a :* e) ans -> Eff e b
 localRet init ret action
-  = Eff (\ctx -> unsafePromptIORef init $ \m r ->  -- set a fresh prompt with marker `m`
+  = Eff (\ctx -> safePromptIORef init $ \m r ->  -- set a fresh prompt with marker `m`
                  do x <- under (CCons m (Local r) CTId ctx) action -- and call action with the extra evidence
-                    y <- unsafeIO (readIORef r)
+                    y <- safeIO (readIORef r)
                     return (ret x y))
 
 -- | Create a local state handler with an initial state of type @a@.