module System.Vacuum.OpenGL.Client
( view
, changePort
, changeHost
)
where
import Control.Monad
import Control.Concurrent.MVar
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 . showHNodes showHN . vacuum) x
send (show dot)
showHN :: ShowHNode
showHN = ShowHNode { showHNode = renderNode , externHNode = \_ -> "..." }
where
renderNode i n = node n ++ "|" ++ show i
showLit n = show (head $ nodeLits n)
node n = case nodeName n of
":" -> "(:)"
k | k `elem` [ "S#", "I#", "W#"
, "I8#", "I16#", "I32#", "I64#"
, "W8#", "W16#", "W32#", "W64#"
] -> k ++ "(" ++ showLit n ++ ")"
"D#" -> "Double"
"F#" -> "Float"
"C#" -> "C#(" ++ (show . chr . fromIntegral . head . nodeLits) n ++ ")"
"PS" -> "ByteString[" ++ show (nodeLits n !! 1) ++ "," ++ show (nodeLits n !! 2) ++ "]"
"Chunk" -> "Chunk[" ++ show (nodeLits n !! 1) ++ "," ++ show (nodeLits n !! 2) ++ "]"
c | z > 0 -> c ++ show (take (fromIntegral z) $ nodeLits n)
| otherwise -> c
where z = itabLits (nodeInfo n)