[Haskell-cafe] Monads with "The" contexts?

[oleg at okmij.org]

The bad news is that indeed you don't seem to be able to do what you
want. The good news: yes, you can. The enclosed code does exactly what
you wanted:

> sunPerMars :: NonDet Double
> sunPerMars = (/) <$> sunMass <*> marsMass
>
> sunPerMars_run = runShare sunPerMars
> sunPerMars_run_len = length sunPerMars_run
> -- 27

where earthMass, sunMass, marsMass are all top-level bindings, which
can be defined in separate and separately-compiled modules.

Let's start with the bad news however. Recall the original problem:

> earthMass, sunMass, marsMass :: [Double]
> earthMass = [5.96e24, 5.97e24, 5.98e24]
> sunMass = (*) <$>  [2.5e5, 3e5, 4e5] <*> earthMass
> marsMass = (*) <$> [0.01, 0.1, 1.0] <*> earthMass

The problem was that the computation 
	sunPerMars = (/) <$> sunMass <*> marsMass
produces too many answers, because earthMass in sunMass and earthMass
in marsMass were independent non-deterministic computations. Thus the
code says: we measure the earthMass to compute sunMass, and we measure
earthMass again to compute marsMass. Each earthMass measurement is
independent and gives us, in general, a different value. 

However, we wanted the code to behave differently. We wanted to
measure earthMass only once, and use the same measured value to
compute masses of other bodies. There does not seem to be a way to do
that in Haskell. Haskell is pure, so we can substitute equals for
equals. earthMass is equal to [5.96e24, 5.97e24, 5.98e24]. Thus the
meaning of program should not change if we write

> sunMass = (*) <$>  [2.5e5, 3e5, 4e5] <*> [5.96e24, 5.97e24, 5.98e24]
> marsMass = (*) <$> [0.01, 0.1, 1.0] <*> [5.96e24, 5.97e24, 5.98e24]

which gives exactly the wrong behavior (and 81 answers for sunPerMars,
as easy to see). Thus there is no hope that the original code should
behave any differently.

> I don't know if memo can solve this problem. I have to test. Is the
> `memo` in your JFP paper section 4.2 Memoization, a psuedo-code? (What
> is type `Thunk` ?) and seems like it's not in explicit-sharing
> hackage.

BTW, the memo in Hansei is different from the memo in the JFP paper.
In JFP, memo is a restricted version of share:
	memo_jfp :: m a -> m (m a)

In Hansei, memo is a generalization of share:
	memo_hansei :: (a -> m b) -> m (a -> m b)

You will soon need that generalization (which is not mention in the
JFP paper).


Given such a let-down, is there any hope at all? Recall, if Haskell
doesn't do what you want, embed a language that does. The solution becomes
straightforward then. (Please see the enclosed code).

Exercise: how does the approach in the code relate to the approaches
to sharing explained in
	http://okmij.org/ftp/tagless-final/sharing/sharing.html

Good luck with the contest!

{-# LANGUAGE FlexibleContexts, DeriveDataTypeable #-}

-- Sharing of top-level bindings
-- Solving Takayuki Muranushi's problem
-- http://www.haskell.org/pipermail/haskell-cafe/2012-July/102287.html

module TopSharing where

import qualified Data.Map as M
import Control.Monad.State
import Data.Dynamic
import Control.Applicative

-- Let's pretend this is one separate module.
-- It exports earthMass, the mass of the Earth, which
-- is a non-deterministic computation producing Double.
-- The non-determinism reflects our uncertainty about the mass.

-- Exercise: why do we need the seemingly redundant EarthMass
-- and deriving Typeable?
-- Could we use TemplateHaskell instead?
data EarthMass deriving Typeable
earthMass :: NonDet Double
earthMass = memoSta (typeOf (undefined::EarthMass)) $
	    msum $ map return [5.96e24, 5.97e24, 5.98e24]


-- Let's pretend this is another separate module
-- It imports earthMass and exports sunMass
-- Muranushi: ``Let's also pretend that we can measure the other 
-- bodies' masses only by their ratio to the Earth mass, and 
-- the measurements have large uncertainties.''

data SunMass deriving Typeable
sunMass :: NonDet Double
sunMass = memoSta (typeOf (undefined::SunMass)) mass
 where mass = (*) <$> proportion <*> earthMass
       proportion = msum $ map return [2.5e5, 3e5, 4e5]

-- Let's pretend this is yet another separate module
-- It imports earthMass and exports marsMass

data MarsMass deriving Typeable
marsMass :: NonDet Double
marsMass = memoSta (typeOf (undefined::MarsMass)) mass
 where mass = (*) <$> proportion <*> earthMass
       proportion = msum $ map return [0.01, 0.1, 1.0]

-- This is the main module, importing the masses of the three bodies
-- It computes ``how many Mars mass object can we create 
-- by taking the sun apart?''
-- This code is exactly the same as in Takayuki Muranushi's message
-- His question: ``Is there a way to represent this? 
-- For example, can we define earthMass'' , sunMass'' , marsMass'' all 
-- in separate modules, and yet have (length $ sunPerMars'' == 27) ?

sunPerMars :: NonDet Double
sunPerMars = (/) <$> sunMass <*> marsMass

sunPerMars_run = runShare sunPerMars
sunPerMars_run_len = length sunPerMars_run
-- 27


-- The following is essentially Control.Monad.Sharing.Memoization
-- with one important addition
-- Can you spot the important addition?

type NonDet a = StateT FirstClassStore [] a
data Key = KeyDyn Int | KeySta TypeRep
	 deriving (Show, Ord, Eq)

-- I wish TypeRep were in Ord by default. The implementation permits that!
instance Ord TypeRep where
    compare x y = compare (show x) (show y)

data FirstClassStore = 
    FirstClassStore { freshKey :: Int, store :: M.Map Key Dynamic }

emptyStore :: FirstClassStore
emptyStore = FirstClassStore { freshKey = 1, store = M.empty }

getFreshKey :: MonadState FirstClassStore m => m Key
getFreshKey = do
  key <- gets freshKey
  modify (\s -> s { freshKey = succ key })
  return (KeyDyn key)

insertVal :: (Typeable a, MonadState FirstClassStore m) => Key -> a -> m ()
insertVal key val =
  modify (\s -> s { store = M.insert key (toDyn val) (store s) })

lookupVal :: (Typeable a, MonadState FirstClassStore m) => Key -> m (Maybe a)
lookupVal key = 
   liftM (liftM (flip fromDyn err) . M.lookup key) (gets store)
 where err = error $ "lookupVal: bad key " ++ show key
       
memo :: (Typeable a, MonadState FirstClassStore m) => m a -> m (m a)
memo a = getFreshKey >>= \key -> return (memoKey key a)

memoSta :: (Typeable a, MonadState FirstClassStore m) => TypeRep -> m a -> m a
memoSta trep a = memoKey (KeySta trep) a

memoKey :: (Typeable a, MonadState FirstClassStore m) => Key -> m a -> m a
memoKey key a = do
  valM <- lookupVal key
  case valM of
    Just x  -> return x
    Nothing -> do
	       x <- a
	       insertVal key $! x
	       return x

runShare :: Monad m => StateT FirstClassStore m a -> m a
runShare m = evalStateT m emptyStore


-- In My GHC, StateT is still not an Applicative. More bolierplate

instance Monad m => Applicative (StateT s m) where
    pure  = return
    (<*>) = liftM2 ($)