Client.hs

-- | Since GLUT+GHCi is problematic at best, after some very frustating
-- experiments I decided on a client-server architecture.
--
-- Usage example:
--
-- > $ vacuum-opengl-server &
-- > vaacum-opengl server started - press ESC to exit. 
-- > listening on port 55961
-- > 
-- > $ ghci
-- > Prelude> :m + System.Vacuum.OpenGL 
-- > Prelude System.Vacuum.OpenGL> view [1..5]
-- > Prelude System.Vacuum.OpenGL> view $ zip "foobar" [1..6]
-- > Prelude System.Vacuum.OpenGL> :m + Data.Set
-- > Prelude System.Vacuum.OpenGL Data.Set> view $ fromList [1..10]
--
-- Note: 
-- 
--  * we need the graphviz executable (called \"dot\") being in the path.
--
--  * we need the server running
--
--  * the image generated by graphviz may be bigger than the maximum texture 
--    size your video card supports (eg. 2048). In this case you will see
--    a white rectangle. TODO: handle this better.
--

module System.Vacuum.OpenGL.Client 
  ( view
  , changePort
  , changeHost
  ) 
  where

--------------------------------------------------------------------------------

import Control.Monad
import Control.Concurrent.MVar

--import Control.Exception

import Data.Char

import GHC.Vacuum
import Text.PrettyPrint.HughesPJ

import System.IO.Unsafe

import Network

--------------------------------------------------------------------------------

defaultPort :: PortID 
defaultPort = PortNumber VACUUM_OPENGL_DEFAULTPORT

defaultHost :: HostName
defaultHost = "127.0.0.1"

--------------------------------------------------------------------------------

thePort :: MVar PortID
thePort = unsafePerformIO $ newMVar defaultPort

theHost :: MVar HostName
theHost = unsafePerformIO $ newMVar defaultHost

--------------------------------------------------------------------------------

send :: String -> IO ()
send text = withSocketsDo $ do
  port <- readMVar thePort
  host <- readMVar theHost
  sendTo host port text

changePort :: Int -> IO ()
changePort n = do
  swapMVar thePort (PortNumber $ fromIntegral n)
  return ()

changeHost :: String -> IO ()
changeHost s = do
  swapMVar theHost s
  return ()
  
view :: a -> IO ()
view x = do
  --let dot = (ppDot . nameGraph . vacuum) x
  let dot = (ppDot . showHNodes showHN . vacuum) x
  send (show dot)
  
--------------------------------------------------------------------------------

-- this function is based on the corresponding one in Don Stewart's vacuum-cairo library  
showHN :: ShowHNode
showHN = ShowHNode { showHNode = renderNode , externHNode  = \_ -> "..." }
  where
    renderNode i n = node n ++ "|" ++ show i -- unique id
    showLit n = show (head $ nodeLits n)
    node n = case nodeName n of
      ":"  -> "(:)"

      -- atomic stuff is special
      k | k `elem` [ "S#", "I#", "W#"
                   , "I8#", "I16#", "I32#", "I64#"
                   , "W8#", "W16#", "W32#", "W64#"
                   ] -> k ++ "(" ++ showLit n ++ ")"

      "D#" -> "Double"
      "F#" -> "Float"

      -- chars
      "C#" -> "C#(" ++ (show . chr . fromIntegral . head . nodeLits) n ++ ")"

      -- bytestrings
      "PS"    -> "ByteString[" ++ show (nodeLits n !! 1) ++ "," ++ show (nodeLits n !! 2) ++ "]"
      "Chunk" -> "Chunk["      ++ show (nodeLits n !! 1) ++ "," ++ show (nodeLits n !! 2) ++ "]"

      -- otherwise just the constructor and local fields
      c | z > 0     -> c ++ show (take (fromIntegral z) $ nodeLits n)
        | otherwise -> c
        where z = itabLits (nodeInfo n)
 
--------------------------------------------------------------------------------