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