MonadSharing.hs

{-# OPTIONS_GHC
    -ddump-simpl
    -dsuppress-idinfo
    -dsuppress-coercions
    -dsuppress-type-applications
    -dsuppress-uniques
    -dsuppress-module-prefixes
#-}

import           Control.Monad
import           Debug.Trace

main = testShareSelfAnd

data State s a = State { runState :: s -> (s, a) }

instance Functor (State s) where
  fmap f (State k) = State (\s -> let (s', x) = k s in (s', f x))

instance Applicative (State s) where
  pure  = return
  (<*>) = ap

instance Monad (State s) where
  return x = State (\s -> (s, x))
  (State k) >>= f = State (\s -> let (s', x) = (k s) in runState (f x) s')
  
-- Pointfree version
-- instance Monad (State s) where
--   return = State . flip (,)
--   (>>=)  = (State .) . flip ((.) . (`ap` snd) . (. fst) . flip . (runState .)) . runState

evalState :: s -> State s a -> a
evalState s st = snd (runState st s)

testShareSelfAnd :: IO ()
testShareSelfAnd = do
  print (evalState 0 (shareSelfAnd (return True)))    -- (1)
  -- print (head        (shareSelfAnd (return True))) -- (2)

shareSelfAnd :: Monad m => m Bool -> m Bool
shareSelfAnd mx = let mb = btrace mx
                  in andM mb mb

btrace :: Monad m => m a -> m a
btrace mx = mx >>= \x -> trace "evaluated" (return x)
-- btrace = (>>= trace "evaluated" . return) -- pointfree btrace

selfAnd :: Monad m => m Bool -> m Bool
selfAnd mb = andM mb mb

andM :: Monad m => m Bool -> m Bool -> m Bool
andM mb1 mb2 = mb1 >>= \b1 -> case b1 of
                                False -> return False
                                True  -> mb2

-- Output for (1): evaluated evaluated True
-- Output for (2): evaluated True