LazyState.hs

{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE Safe #-}

-- | On-demand state computation:
-- example taken from Edward Kmett's comment here:
-- <http://www.reddit.com/r/haskell/comments/387ex0/are_extensible_effects_a_complete_replacement_for/crt1pzm>
--
-- Extensible effects make it clear that where the computation is delayed and
-- they do maintain the degree of extensibility (the delayed computation must be
-- effect-closed, but the whole computation does not have to be).
module Control.Eff.State.LazyState where

import Control.Eff

-- | Define a new effect for state on-demand (in ExtEff, the state is
-- by default strict -- as it should be if we want the predictable performance
-- and effect sequencing)
data LazyState s v where
  LGet  :: LazyState s s
  LPut  :: s -> LazyState s ()
  Delay :: Eff '[LazyState s] a  -> LazyState s a --  Eff as a transformer

-- | Primitive state operations
lget :: Member (LazyState s) r => Eff r s
lget = send LGet

lput :: Member (LazyState s) r => s -> Eff r ()
lput = send . LPut

lmodify :: (Member (LazyState s) r, Member (LazyState t) r)
        => (t -> s) -> Eff r ()
lmodify f = do
  s <- lget
  lput (f s)

onDemand :: Member (LazyState s) r => Eff '[LazyState s] v -> Eff r v
onDemand = send . Delay

-- | The handler
runStateLazy :: s -> Eff (LazyState s ': r) a -> Eff r (a,s)
runStateLazy s = handle_relay_s s (\s0 x -> return (x,s0))
                   (\s0 req k -> case req of
                       LGet    -> k s0 s0
                       LPut s1  -> k s1 ()
                       Delay m -> let ~(x,s1) = run $ runStateLazy s0 m
                                  in k s1 x)

-- | Backwards state
-- The overall state is represented with two attributes: the inherited
-- getAttr and the synthesized putAttr.
-- At the root node, putAttr becomes getAttr, tying the knot.
-- As usual, the inherited attribute is the argument (i.e., the `environment')
-- and the synthesized is the result of the handler |go| below.
runStateBack0 :: Eff '[LazyState s] a -> (a,s)
runStateBack0 m =
  let (x,s) = go s m in
  (x,s)
 where
   go :: s -> Eff '[LazyState s] a -> (a,s)
   go s (Val x) = (x,s)
   go s (E u q) = case decomp u of
         Right LGet      -> go s $ (q ^$ s)
         Right (LPut s1)  -> let ~(x,sp) = go sp $ (q ^$ ()) in (x,s1)
         Right (Delay m1) -> let ~(x,s1) = go s m1 in go s1 $ (q ^$ x)
         Left _ -> error "LazyState: the impossible happened: Union []"

-- | Another implementation, exploring Haskell's laziness to make putAttr
-- also technically inherited, to accumulate the sequence of
-- updates. This implementation is compatible with deep handlers, and
-- lets us play with different notions of `backwardness'
runStateBack :: Eff '[LazyState s] a -> (a,s)
runStateBack m =
  let (x,(_,sp)) = run $ go (sp,[]) m in
  (x,head sp)
 where
   go :: ([s],[s]) -> Eff '[LazyState s] a -> Eff '[] (a,([s],[s]))
   go ss = handle_relay_s ss (\ss1 x -> return (x,ss1))
                   (\ss1@(sg,sp) req k -> case req of
                       LGet    -> k ss1 (head sg)
                       LPut s  -> k (tail sg,sp++[s]) ()
                       Delay m1 -> let ~(x,ss2) = run $ go ss1 m1
                                  in k ss2 x)

-- A different notion of `backwards' is realized if we change the LPut
-- handler slightly. How?