-----------------------------------------------------------------------------
-- |
-- Module      :  Debug.Observe
-- Copyright   :  
-- License     :  BSD3
--
-- Maintainer  :  hpacheco@di.uminho.pt
-- Stability   :  experimental
-- Portability :  non-portable
--
-- GHood:
-- A graphical viewer for Hood
--
--
-- Created a cabal library package.
-- Improved the search for the GHood.jar file, that is bundled with the library.
-- Changed from Literate Haskell to plain Haskell for better haddock documentation support.
--
-- Hugo Pacheco, November 2008
--
-- Added ObserveM.
-- Adapted imports to use GHC's hierarchical libraries.
--
-- Alcino Cunha, February 2004
--
-- Modified version of Hood/Observe.lhs to match GHood, 
-- the Graphical Haskell Object Observation Debugger, which
-- is distributed as a Java class file archive GHood.jar.
-- [Apart from two new hooks, modifications are at the end]
--
-- Claus Reinke, December 2000
--
-- The file is part of the Haskell Object Observation Debugger,
-- (HOOD) July 2000 release. Actually this is all of this version
-- of HOOD, apart from the documentation and examples...
--
-- HOOD is a small post-mortem debugger for the lazy functional
-- language Haskell. It is based on the concept of observation of
-- intermediate data structures, rather than the more traditional
-- stepping and variable examination paradigm used by imperative
-- language debuggers.
--
-- Copyright (c) Andy Gill, 1992-2000

-- All rights reserved. HOOD is distributed as free software under
-- the license in the file "License", which available from the HOOD
-- web page, http://www.haskell.org/hood

-- This module produces CDS's, based on the observation made on Haskell
-- objects, including base types, constructors and functions.
--
-----------------------------------------------------------------------------


module Debug.Observe (
    observe
  , Observer(..)
  , Observing
  , Observable(..)
  , runO
  , printO
  , putStrO
  , ObserverM(..)
  -- * For advanced users, that want to render their own datatypes.
  , (<<)
  , thunk
  , send
  , observeBase
  , observeOpaque
  , Parent(..)
  -- * For users that want to write their own render drivers.
  , debugO
  , CDS(..)
  , CDSSet

  ) where

import Prelude hiding ((<>))
import System.IO
import System.Cmd
import Data.Maybe
import Control.Applicative
import Control.Monad
import Data.Array as Array
import Data.List
import Data.IORef
import Control.Concurrent
-- The library-dependent import
import Paths_GHood
-- The only non standard one we assume
import System.IO.Unsafe

infixl 9 <<

-- * External start functions

-- | Debugs observe ridden code.
debugO :: IO a -> IO [CDS]
debugO program = 
     do { initUniq
	; startEventStream
        ; let errorMsg e = "[Escaping Exception in Code : " ++ show e ++ "]"
	; ourCatchAllIO (do { program ; return () }) 
			(hPutStrLn stderr . errorMsg)
        ; events <- endEventStream
	; return (eventsToCDS events)
	}

-- | Runs and prints observe ridden code.
printO :: (Show a) => a -> IO ()
printO = runO . print

-- | Prints a string during observation.
putStrO :: String -> IO ()
putStrO = runO . putStr

-- | Runs observe ridden code.
runO :: IO a -> IO ()
runO program =
    do { cdss <- debugO program
       ; let cdss1 = rmEntrySet cdss
       ; let cdss2 = simplifyCDSSet cdss1
       ; let output1 = cdssToOutput cdss2 
       ; let output2 = commonOutput output1
       ; let ptyout  = pretty 80 (foldr (<>) nil (map renderTop output2))
       ; hPutStrLn stderr ""
       ; hPutStrLn stderr ptyout
       }

-- * Simulations

-- Here we provide stubs for the functionally that is not supported
-- by some compilers, and provide some combinators of various flavors.

ourCatchAllIO :: IO a -> (() -> IO a) -> IO a
ourCatchAllIO = const

handleExc :: (Observable a) => Parent -> () -> IO a
handleExc = undefined

-- * Instances

-- The Haskell Base types

instance Observable Int 	where { observer = observeBase }
instance Observable Bool 	where { observer = observeBase }
instance Observable Integer 	where { observer = observeBase }
instance Observable Float 	where { observer = observeBase }
instance Observable Double	where { observer = observeBase }
instance Observable Char 	where { observer = observeBase }

instance Observable ()		where { observer = observeOpaque "()" }

-- | Observe a base type
observeBase :: (Show a) => a -> Parent -> a
observeBase lit = seq lit . send (show lit) (return lit)
-- ^ The strictness (by using seq) is the same as the pattern matching done on other constructors.
-- We evaluate to WHNF, and not further.

-- | Observe a base type as an 'opaque' string.
observeOpaque :: String -> a -> Parent -> a
observeOpaque str val = seq val . send str (return val)

-- The Constructors.

instance (Observable a,Observable b) => Observable (a,b) where
  observer (a,b) = send "," (return (,) << a << b)

instance (Observable a,Observable b,Observable c) => Observable (a,b,c) where
  observer (a,b,c) = send "," (return (,,) << a << b << c)

instance (Observable a,Observable b,Observable c,Observable d) 
	  => Observable (a,b,c,d) where
  observer (a,b,c,d) = send "," (return (,,,) << a << b << c << d)

instance (Observable a,Observable b,Observable c,Observable d,Observable e) 
	 => Observable (a,b,c,d,e) where
  observer (a,b,c,d,e) = send "," (return (,,,,) << a << b << c << d << e)

instance (Observable a) => Observable [a] where
  observer (a:as) = send ":"  (return (:) << a << as)
  observer []     = send "[]" (return [])

instance (Observable a) => Observable (Maybe a) where
  observer (Just a) = send "Just"    (return Just << a)
  observer Nothing  = send "Nothing" (return Nothing)

instance (Observable a,Observable b) => Observable (Either a b) where
  observer (Left a)  = send "Left"  (return Left  << a)
  observer (Right a) = send "Right" (return Right << a)

-- Arrays.

instance (Ix a,Observable a,Observable b) => Observable (Array.Array a b) where
  observer arr = send "array" (return Array.array << Array.bounds arr 
					          << Array.assocs arr)
			
-- IO monad.

instance (Observable a) => Observable (IO a) where
  observer fn cxt = 
	do res <- fn
	   send "<IO>" (return return << res) cxt
	
-- We treat IOError this like a base value. Cheating a bit, but if you
--	generate an IOError with a bottom in it, your just asking for trouble.

instance Observable IOError where
	observer = observeBase
	
-- Functions.

instance (Observable a,Observable b) => Observable (a -> b) where
  observer fn cxt arg = sendObserveFnPacket (
	do arg <- thunk arg
	   thunk (fn arg)) cxt

  observers = defaultFnObservers

-- The Exception *datatype* (not exceptions themselves!).
-- For now, we only display IOExceptions and calls to Error.

-- * Classes and Data Defintions

class Observable a where
	{-|
	 This reveals the name of a specific constructor.
	 and gets ready to explain the sub-components.
    We put the context second so we can do eta-reduction
	 with some of our definitions.
	 -}
	observer  :: a -> Parent -> a 
	{-| 
    This used used to group several observer instances together.
	 -}
	observers :: String -> (Observer -> a) -> a
	observers = defaultObservers

type Observing a = a -> a

-- | Contains a 'forall' typed observe (if supported).
newtype Observer = O (forall a . (Observable a) => String -> a -> a)

defaultObservers :: (Observable a) => String -> (Observer -> a) -> a
defaultObservers label fn = unsafeWithUniq $ \ node ->
     do { sendEvent node (Parent 0 0) (Observe label)
	; let observe' sublabel a
	       = unsafeWithUniq $ \ subnode ->
		 do { sendEvent subnode (Parent node 0) 
		                        (Observe sublabel)
		    ; return (observer_ a Parent
			{ observeParent = subnode
			, observePort   = 0
		        })
		    }
        ; return (observer_ (fn (O observe'))
		       Parent
			{ observeParent = node
			, observePort   = 0
		        })
	}
defaultFnObservers :: (Observable a,Observable b) => String -> (Observer -> a -> b) -> a -> b
defaultFnObservers label fn arg = unsafeWithUniq $ \ node ->
     do { sendEvent node (Parent 0 0) (Observe label)
	; let observe' sublabel a
	       = unsafeWithUniq $ \ subnode ->
		 do { sendEvent subnode (Parent node 0) 
		                        (Observe sublabel)
		    ; return (observer_ a Parent
			{ observeParent = subnode
			, observePort   = 0
		        })
		    }
        ; return (observer_ (fn (O observe'))
		       Parent
			{ observeParent = node
			, observePort   = 0
		        } arg)
	}
	
-- * The ObserveM Monad

-- | A simple state monad for placing numbers on sub-observations.
newtype ObserverM a = ObserverM { runMO :: Int -> Int -> (a,Int) }

instance Functor ObserverM where
	fmap  = liftM

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

instance Monad ObserverM where
	return a = ObserverM (\ c i -> (a,i))
	fn >>= k = ObserverM (\ c i ->
		case runMO fn c i of
		  (r,i2) -> runMO (k r) c i2
		)

-- | thunk is for marking suspensions.
thunk :: (Observable a) => a -> ObserverM a
thunk a = ObserverM $ \ parent port ->
		( observer_ a Parent
				{ observeParent = parent
				, observePort   = port
				}
		, port+1 )

-- | the infix (<<) is a shortcut for constructor arguments.
(<<) :: (Observable a) => ObserverM (a -> b) -> a -> ObserverM b
fn << a = do { fn' <- fn ; a' <- thunk a ; return (fn' a') }

-- * Observe and friends

{-# NOINLINE observe #-}
-- | Our principle function and class
observe :: (Observable a) => String -> a -> a
observe = generateContext 

{-# NOINLINE observer_ #-}
{-|
 This gets called before observer, allowing us to mark
 we are entering a, before we do case analysis on
 our object.
 -}
observer_ :: (Observable a) => a -> Parent -> a 
observer_ = sendEnterPacket

-- | Parent book-keeping information.
data Parent = Parent
	{ observeParent :: !Int	-- ^ my parent
	, observePort   :: !Int	-- ^ my branch number
	} deriving Show
root = Parent 0 0

-- The functions that output the data. All are dirty.

unsafeWithUniq :: (Int -> IO a) -> a
unsafeWithUniq fn 
  = unsafePerformIO $ do { node <- getUniq
		         ; fn node
		         }

generateContext :: (Observable a) => String -> a -> a
generateContext label orig = unsafeWithUniq $ \ node ->
     do { sendEvent node (Parent 0 0) (Observe label)
	; return (observer_ orig Parent
			{ observeParent = node
			, observePort   = 0
		        }
		  )
	}

-- | Sends a packet to the observation agent.
send :: String -> ObserverM a -> Parent -> a
send consLabel fn context = unsafeWithUniq $ \ node ->
     do { let (r,portCount) = runMO fn node 0
	; sendEvent node context (Cons portCount consLabel)
	; return r
	}

sendEnterPacket :: (Observable a) => a -> Parent -> a
sendEnterPacket r context = unsafeWithUniq $ \ node ->
     do	{ sendEvent node context Enter
	; ourCatchAllIO (evaluate (observer r context))
	                (handleExc context)
	}

evaluate :: a -> IO a
evaluate a = a `seq` return a

sendObserveFnPacket :: ObserverM a -> Parent -> a
sendObserveFnPacket fn context = unsafeWithUniq $ \ node ->
     do	{ let (r,_) = runMO fn node 0
	; sendEvent node context Fun
	; return r
	}

-- * Event stream

-- Trival output functions

data Event = Event
		{ portId     :: !Int
		, parent     :: !Parent
		, change     :: !Change
		}
	deriving Show

data Change
	= Observe 	!String
	| Cons    !Int 	!String
	| Enter
	| Fun
	deriving Show

startEventStream :: IO ()
startEventStream = writeIORef events []

endEventStream :: IO [Event]
endEventStream =
	do { es <- readIORef events
	   ; writeIORef events badEvents 
	   ; eventsHook es                            -- cr, use return () as default
	   ; return es
	   }

sendEvent :: Int -> Parent -> Change -> IO ()
sendEvent nodeId parent change =
	do { nodeId `seq` parent `seq` return ()
	   ; change `seq` return ()
	   ; takeMVar sendSem
	   ; es <- readIORef events
	   ; let event = Event nodeId parent change
	   ; writeIORef events (event `seq` (event : es))
	   ; eventHook event                            -- cr, use return () as default
	   ; putMVar sendSem ()
	   }

-- local
events :: IORef [Event]
events = unsafePerformIO $ newIORef badEvents

badEvents :: [Event]
badEvents = error "Bad Event Stream"

{-# NOINLINE sendSem #-}
-- use as a trivial semiphore
sendSem :: MVar ()
sendSem = unsafePerformIO $ newMVar ()
-- end local


-- * Unique name supply code

-- Use the single threaded version

initUniq :: IO ()
initUniq = do
	u <- readIORef uniq
	when (u/=1) $ hPutStrLn stderr 
		"Warning[Debug.Observe]: reinitializing event counter (may lead to invalid event log\n\
		\  if 'runO'/'printO' encounters already partially observed structures)"
	writeIORef uniq 1

getUniq :: IO Int
getUniq
    = do { takeMVar uniqSem
	 ; n <- readIORef uniq
	 ; writeIORef uniq $! (n + 1)
	 ; putMVar uniqSem ()
	 ; return n
	 }

peepUniq :: IO Int
peepUniq = readIORef uniq

-- locals
{-# NOINLINE uniq #-}
uniq :: IORef Int
uniq = unsafePerformIO $ newIORef 1

{-# NOINLINE uniqSem #-}
uniqSem :: MVar ()
uniqSem = unsafePerformIO $ newMVar ()

-- * Global, initializers, etc

openObserveGlobal :: IO ()
openObserveGlobal =
     do { initUniq
	; startEventStream
	}

closeObserveGlobal :: IO [Event]
closeObserveGlobal =
     do { evs <- endEventStream
        ; putStrLn ""
	; return evs
	}
	
-- * The CDS and converting functions

data CDS = CDSNamed String         CDSSet
	 | CDSCons Int String     [CDSSet]
	 | CDSFun  Int             CDSSet CDSSet
	 | CDSEntered Int
	deriving (Show,Eq,Ord)

type CDSSet = [CDS]


eventsToCDS :: [Event] -> CDSSet
eventsToCDS pairs = getChild 0 0
   where
     res = (!) out_arr

     bnds = (0, length pairs)

     mid_arr :: Array Int [(Int,CDS)]
     mid_arr = accumArray (flip (:)) [] bnds
		[ (pnode,(pport,res node))
	        | (Event node (Parent pnode pport) _) <- pairs
		]

     out_arr = array bnds	-- never uses 0 index
	        [ (node,getNode'' node change)
	 	| (Event node _ change) <- pairs
		]

     getNode'' ::  Int -> Change -> CDS
     getNode'' node change =
       case change of
	(Observe str) -> CDSNamed str (getChild node 0)
	(Enter)       -> CDSEntered node
	(Fun)         -> CDSFun node (getChild node 0) (getChild node 1)
	(Cons portc cons)
		      -> CDSCons node cons 
				[ getChild node n | n <- [0..(portc-1)]]

     getChild :: Int -> Int -> CDSSet
     getChild pnode pport =
	[ content
        | (pport',content) <- (!) mid_arr pnode
	, pport == pport'
	]

render  :: Int -> Bool -> CDS -> DOC
render prec par (CDSCons _ ":" [cds1,cds2]) =
	if par && not needParen
	then doc -- dont use paren (..) because we dont want a grp here!
	else paren needParen doc
   where
	doc = grp (brk <> renderSet' 5 False cds1 <> text " : ") <>
	      renderSet' 4 True cds2
	needParen = prec > 4
render prec par (CDSCons _ "," cdss) | length cdss > 0 =
	nest 2 (text "(" <> foldl1 (\ a b -> a <> text ", " <> b)
			    (map renderSet cdss) <>
		text ")")
render prec par (CDSCons _ name cdss) =
	paren (length cdss > 0 && prec /= 0)
	      (nest 2
	         (text name <> foldr (<>) nil
			 	[ sep <> renderSet' 10 False cds
			 	| cds <- cdss 
			 	]
		 )
	      )

-- renderSet handles the various styles of CDSSet.

renderSet :: CDSSet -> DOC
renderSet = renderSet' 0 False

renderSet' :: Int -> Bool -> CDSSet -> DOC
renderSet' _ _      [] = text "_"
renderSet' prec par [cons@(CDSCons {})]    = render prec par cons
renderSet' prec par cdss		   = 
	nest 0 (text "{ " <> foldl1 (\ a b -> a <> line <>
				    text ", " <> b)
				    (map renderFn pairs) <>
	        line <> text "}")

   where
	pairs = nub (sort (findFn cdss))
	-- local nub for sorted lists
	nub []                  = []
	nub (a:a':as) | a == a' = nub (a' : as)
        nub (a:as)              = a : nub as

renderFn :: ([CDSSet],CDSSet) -> DOC
renderFn (args,res) 
	= grp  (nest 3 
		(text "\\ " <>
		 foldr (\ a b -> nest 0 (renderSet' 10 False a) <> sp <> b)
		       nil
		       args <> sep <>
		 text "-> " <> renderSet' 0 False res
		)
               )

findFn :: CDSSet -> [([CDSSet],CDSSet)]
findFn = foldr findFn' []

findFn' (CDSFun _ arg res) rest =
    case findFn res of
       [(args',res')] -> (arg : args', res') : rest
       _              -> ([arg], res) : rest
findFn' other rest = ([],[other]) : rest

renderTops []   = nil
renderTops tops = line <> foldr (<>) nil (map renderTop tops)

renderTop :: Output -> DOC
renderTop (OutLabel str set extras) =
	nest 2 (text ("-- " ++ str) <> line <>
		renderSet set
		<> renderTops extras) <> line

rmEntry :: CDS -> CDS
rmEntry (CDSNamed str set)   = CDSNamed str (rmEntrySet set)
rmEntry (CDSCons i str sets) = CDSCons i str (map rmEntrySet sets)
rmEntry (CDSFun i a b)       = CDSFun i (rmEntrySet a) (rmEntrySet b)
rmEntry (CDSEntered i)       = error "found bad CDSEntered"

rmEntrySet = map rmEntry . filter noEntered
  where
	noEntered (CDSEntered _) = False
	noEntered _              = True

simplifyCDS :: CDS -> CDS
simplifyCDS (CDSNamed str set) = CDSNamed str (simplifyCDSSet set)
simplifyCDS (CDSCons _ "throw" 
		  [[CDSCons _ "ErrorCall" set]]
	    ) = simplifyCDS (CDSCons 0 "error" set)
simplifyCDS cons@(CDSCons i str sets) = 
	case spotString [cons] of
	  Just str | not (null str) -> CDSCons 0 (show str) []
	  _ -> CDSCons 0 str (map simplifyCDSSet sets)

simplifyCDS (CDSFun i a b) = CDSFun 0 (simplifyCDSSet a) (simplifyCDSSet b)
	-- replace with 
	-- 	CDSCons i "->" [simplifyCDSSet a,simplifyCDSSet b]
	-- for turning off the function stuff.

simplifyCDSSet = map simplifyCDS 

spotString :: CDSSet -> Maybe String
spotString [CDSCons _ ":"
		[[CDSCons _ str []]
		,rest
		]
	   ] 
	= do { ch <- case reads str of
	               [(ch,"")] -> return ch
                       _ -> Nothing
	     ; more <- spotString rest
	     ; return (ch : more)
	     }
spotString [CDSCons _ "[]" []] = return []
spotString other = Nothing

paren :: Bool -> DOC -> DOC
paren False doc = grp (nest 0 doc)
paren True  doc = grp (nest 0 (text "(" <> nest 0 doc <> brk <> text ")"))

sp :: DOC
sp = text " "

data Output = OutLabel String CDSSet [Output]
            | OutData  CDS
	      deriving (Eq,Ord)


commonOutput :: [Output] -> [Output]
commonOutput = sortBy byLabel
  where
     byLabel (OutLabel lab _ _) (OutLabel lab' _ _) = compare lab lab'

cdssToOutput :: CDSSet -> [Output]
cdssToOutput =  map cdsToOutput

cdsToOutput (CDSNamed name cdsset)
	    = OutLabel name res1 res2
  where
      res1 = [ cdss | (OutData cdss) <- res ]
      res2 = [ out  | out@(OutLabel {}) <- res ]
      res  = cdssToOutput cdsset
cdsToOutput cons@(CDSCons {}) = OutData cons
cdsToOutput    fn@(CDSFun {}) = OutData fn

-- * Quickcheck stuff

-- * A Pretty Printer

-- This pretty printer is based on Wadler's pretty printer.

data DOC		= NIL			-- nil	  
			| DOC :<> DOC		-- beside 
			| NEST Int DOC
			| TEXT String
			| LINE			-- always "\n"
			| SEP			-- " " or "\n"
			| BREAK			-- ""  or "\n"
			| DOC :<|> DOC		-- choose one
			deriving (Eq,Show)
data Doc		= Nil
			| Text Int String Doc
			| Line Int Int Doc
			deriving (Show,Eq)


mkText			:: String -> Doc -> Doc
mkText s d		= Text (toplen d + length s) s d

mkLine			:: Int -> Doc -> Doc
mkLine i d		= Line (toplen d + i) i d

toplen			:: Doc -> Int
toplen Nil		= 0
toplen (Text w s x)	= w
toplen (Line w s x)	= 0

nil	 = NIL
x <> y = x :<> y
nest	 = NEST
text	 = TEXT
line	 = LINE
sep	 = SEP
brk	 = BREAK

fold x			= grp (brk <> x)

grp 			:: DOC -> DOC
grp x			= 
	case flatten x of
	  Just x' -> x' :<|> x
	  Nothing -> x

flatten 		:: DOC -> Maybe DOC
flatten	NIL		= return NIL
flatten (x :<> y)	= 
	do x' <- flatten x
	   y' <- flatten y
	   return (x' :<> y')
flatten (NEST i x)	= 
	do x' <- flatten x
	   return (NEST i x')
flatten (TEXT s)	= return (TEXT s)
flatten LINE		= Nothing		-- abort
flatten SEP		= return (TEXT " ")	-- SEP is space
flatten BREAK		= return NIL		-- BREAK is nil
flatten (x :<|> y)	= flatten x

layout 			:: Doc -> String
layout Nil		= ""
layout (Text _ s x)	= s ++ layout x
layout (Line _ i x)	= '\n' : replicate i ' ' ++ layout x

best w k doc = be w k [(0,doc)]

be 			:: Int -> Int -> [(Int,DOC)] -> Doc
be w k []		= Nil
be w k ((i,NIL):z)	= be w k z
be w k ((i,x :<> y):z)	= be w k ((i,x):(i,y):z)
be w k ((i,NEST j x):z) = be w k ((k+j,x):z)
be w k ((i,TEXT s):z)	= s `mkText` be w (k+length s) z
be w k ((i,LINE):z)	= i `mkLine` be w i z
be w k ((i,SEP):z)	= i `mkLine` be w i z
be w k ((i,BREAK):z)	= i `mkLine` be w i z
be w k ((i,x :<|> y):z) = better w k 
				(be w k ((i,x):z))
				(be w k ((i,y):z))

better			:: Int -> Int -> Doc -> Doc -> Doc
better w k x y		= if (w-k) >= toplen x then x else y

pretty :: Int -> DOC -> String
pretty w	= layout . best w 0

-- * GHood connection

-- Connection to GHood graphical browser (via eventsHook).

observeEventsLog = "ObserveEvents.log"
call_GHood       = do
   ghood <- getDataFileName "GHood.jar"
   let call = "java -cp \"" ++ ghood ++ "\" GHood " ++ observeEventsLog
   hPutStrLn stderr call   
   system call

eventHook e   = return () -- currently not used
eventsHook es = 
  do
    connectBrowser
    mapM_ (sendBrowser.toBrowser) (reverse es)
    disconnectBrowser

toBrowser e = 
       show (portId e)
       ++ " " ++ show (observeParent (parent e))
       ++ " " ++ show (observePort (parent e))
       ++ " " ++ (case change e of
              { Observe s -> "Observe |" ++ s
              ; Cons n  s -> "Cons " ++ show n ++ " |" ++ s
              ; Enter     -> "Enter"
              ; Fun       -> "Fun"
              })

global_Browser_pipe_ref = unsafePerformIO $ 
  newIORef (error "not connected to GHood browser")

connectBrowser = 
  do
    pipe <- openFile observeEventsLog WriteMode
    writeIORef global_Browser_pipe_ref pipe

disconnectBrowser = 
  do
    pipe <- readIORef global_Browser_pipe_ref
    writeIORef global_Browser_pipe_ref (error "not connected to Browser")
    hClose pipe
    call_GHood

sendBrowser cmd = 
  do
    pipe <- readIORef global_Browser_pipe_ref
    hPutStrLn pipe cmd
    hFlush pipe