neat trick: parallel show

[John Meacham]

while working on a random project, I had opprotunity to write a 'parallel show'
which concurrently evaluates everything needed to show a structure and lets you
print succesivly refined versions as vaules are calculated and filled in. it is
nice because a value that takes a long time (or perhaps forever) to evaluate at
the front of your structure doesn't keep you from seeing what else is in it. I
must say it has been a very useful little bit of code so thought I might share
the concept and was curious if anyone else does things like this..


it works something like
foo = [Right "foo", Left undefined, undefined, Right "here"]
parShow (parPretty foo) >>= putStrLn
=> "(Right foo) (Left _|_) _|_ (Right here)"

and succesive calls to parShow will fill in the _|_ values as they get evaluated.

my attached implementation is rather weak (my real one is tied into a project
and does wierd things with ANSI escape codes to redraw the screen as things get
evaluated and handles exceptions differently) but the gist is the same.

would people be interesting in me( or someone else :) ) turning this
into a full fledged library?  does one alreoady exist which does this? I
was thinking integrating it into a real pretty printing system would be
handy but might be too much work, if there were a way to reuse an
existing pretty printing library without change and somehow add this
capability then that would be cool. I couldn't think of a way to do it
since the final 'render' routine obviously needs to be in the IO monad
so the MVars can be checked again when rerendering..

        John

-- 
---------------------------------------------------------------------------
John Meacham - California Institute of Technology, Alum. - john at foo.net
---------------------------------------------------------------------------
-------------- next part --------------
module Main(main) where

import Control.Concurrent
import Maybe
import Monad
import System.IO.Unsafe
import Control.Exception

infixr 5 </>
infixr 6 <>,<+>

data Doc = DocStr !String  | DocPost !Doc !(MVar Doc)  | DocCat !Doc !Doc 

text s = DocStr s

a <> b = DocCat a b
a <+> b = a <> text " " <> b
a </> b = a <> text "\n" <> b

post els d = DocPost  els $! unsafePerformIO $  do
    mv <- newEmptyMVar 
    forkIO $ do 
        handle (\_ -> return ()) $ evaluate d >>= putMVar mv
    return mv

postb d = post (text "_|_") d

parShow :: Doc -> IO String
parShow (DocStr s) = return s
parShow (DocCat a b) = do
    na <- parShow a 
    nb <- parShow b
    return (na ++ nb)
parShow (DocPost els mv) = do
    md <- tryTakeMVar mv
    parShow (fromMaybe els md)

parShowAll :: Doc -> String
parShowAll (DocStr s) =  s
parShowAll (DocCat a b) = parShowAll a ++ parShowAll b
parShowAll (DocPost _ mv) = parShowAll (unsafePerformIO $ readMVar mv )


foo = [Right "foo", Left undefined, undefined, Right "here"]
foo2 = undefined

parPretty xs = postb (foldl (<+>) (text "") $ map (postb . parPrettyE) xs)
parPrettyE (Left l) = text "(Left" <+> postb (text l) <> text ")"
parPrettyE (Right r) = text "(Right" <+> postb (text r) <> text ")"

main = do
    let foo_p = parPretty foo
    let foo2_p = parPretty foo2
    putStrLn "parShow foo_p"
    parShow foo_p >>= putStrLn
    putStrLn "parShow foo2_p"
    parShow foo2_p >>= putStrLn
    putStrLn "parShow foo_p"
    parShow foo_p >>= putStrLn
    --putStrLn "parShowAll foo"
    --putStrLn $ parShowAll foo_p