vacuum-opengl (empty) → 0.0

raw patch · 7 files changed

+534/−0 lines, 7 filesdep +GLUTdep +OpenGLdep +basesetup-changed

Dependencies added: GLUT, OpenGL, base, directory, network, pretty, process, stb-image, vacuum

Files

• LICENSE +32/−0
• ServerMain.hs +7/−0
• Setup.lhs +5/−0
• System/Vacuum/OpenGL.hs +7/−0
• System/Vacuum/OpenGL/Client.hs +125/−0
• System/Vacuum/OpenGL/Server.hs +302/−0
• vacuum-opengl.cabal +56/−0

@@ -0,0 +1,32 @@+http://creativecommons.org/licenses/publicdomain/+-------------------------------------------------++Copyright-Only Dedication (based on United States law) or +Public Domain Certification++The person or persons who have associated work with this document (the +"Dedicator" or "Certifier") hereby either (a) certifies that, to the best of +his knowledge, the work of authorship identified is in the public domain +of the country from which the work is published, or (b) hereby dedicates +whatever copyright the dedicators holds in the work of authorship identified +below (the "Work") to the public domain. A certifier, moreover, dedicates any +copyright interest he may have in the associated work, and for these purposes, +is described as a "dedicator" below.++A certifier has taken reasonable steps to verify the copyright status of this +work. Certifier recognizes that his good faith efforts may not shield him +from liability if in fact the work certified is not in the public domain.++Dedicator makes this dedication for the benefit of the public at large and +to the detriment of the Dedicator's heirs and successors. Dedicator intends +this dedication to be an overt act of relinquishment in perpetuity of all +present and future rights under copyright law, whether vested or contingent, +in the Work. Dedicator understands that such relinquishment of all rights +includes the relinquishment of all rights to enforce (by lawsuit or otherwise) +those copyrights in the Work.++Dedicator recognizes that, once placed in the public domain, the Work may +be freely reproduced, distributed, transmitted, used, modified, built upon, +or otherwise exploited by anyone for any purpose, commercial or non-commercial, +and in any way, including by methods that have not yet been invented or +conceived.

@@ -0,0 +1,7 @@++module Main where++import System.Vacuum.OpenGL.Server++main :: IO ()+main = serverMain

@@ -0,0 +1,5 @@+#! /usr/bin/env runhaskell+> +> import Distribution.Simple+> main = defaultMain+>

@@ -0,0 +1,7 @@++module System.Vacuum.OpenGL+  ( module System.Vacuum.OpenGL.Client+  )+  where+  +import System.Vacuum.OpenGL.Client

@@ -0,0 +1,125 @@++-- | 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)+ +--------------------------------------------------------------------------------+

@@ -0,0 +1,302 @@++-- | The vacuum-opengl server. This compiles to the executable+-- \"vacuum-opengl-server\", which you need to start to be able+-- to use the +--++module System.Vacuum.OpenGL.Server where++--------------------------------------------------------------------------------++import Control.Monad+import Control.Concurrent+import Control.Concurrent.MVar++import Control.Exception++import Data.Char++import Graphics.Rendering.OpenGL+import Graphics.UI.GLUT++import Codec.Image.STB++import System.Cmd+import System.Directory+import System.Environment+import System.Exit++import System.IO+import System.IO.Unsafe++import Network++import Foreign++--------------------------------------------------------------------------------++defaultPort :: PortID +defaultPort = PortNumber VACUUM_OPENGL_DEFAULTPORT++--------------------------------------------------------------------------------++theTexture :: MVar (Maybe (TextureObject,(Int,Int)))+theTexture = unsafePerformIO $ newMVar Nothing++theImage :: MVar (Maybe Image)+theImage = unsafePerformIO $ newMVar Nothing++--------------------------------------------------------------------------------++showPort :: PortID -> String+showPort p = case p of+  PortNumber n -> show n+--  Service s    -> s+--  UnixSocket s -> s     -- UnixSocket does not exists on Windows?+  _ -> "unknown port type"+    +startServer :: PortID -> IO ()+startServer port = withSocketsDo $ do+  putStrLn "vacuum-opengl-server started - press ESC to exit."+  putStrLn $ "listening on port " ++ showPort port+  listen port++listen port = do +  socket <- listenOn port+  sequence_ $ repeat $ acceptConnectionAndFork socket++showConn :: (Handle, HostName, PortNumber) -> String+showConn (handle, hostname, portnumber) = hostname ++ ":" ++ show portnumber++acceptConnectionAndFork :: Socket -> IO ()+acceptConnectionAndFork socket = do+  conn <- accept socket+  forkIO (server conn)+  return ()+  +server conn@(handle, hostname, portnumber) = do+  text <- hGetContents handle+  length text `seq` view text+  hClose handle+    +--------------------------------------------------------------------------------++graphvizPath :: MVar FilePath+graphvizPath = unsafePerformIO $ do +  findExecutable "dot" >>= \m -> case m of+    Nothing   -> error "graphviz executable \"dot\" not found"+    Just path -> newMVar path++runGraphviz :: [String] -> IO ()+runGraphviz params = do+  path <- readMVar graphvizPath+  exitcode <- rawSystem path params+  when (exitcode /= ExitSuccess) $ +    error "error running graphviz"+  return ()+      +convertToPNG :: String -> IO Image+convertToPNG input = do+  tmp <- getTemporaryDirectory+  let dot = tmp ++ "vacuum-opengl-temp.dot"+      png = tmp ++ "vacuum-opengl-temp.png"+  writeFile dot input+ +--  print dot+--  print png+  +  runGraphviz [ "-Tpng" , "-o"++png , dot ]++  img <- loadImage png >>= \m -> case m of+    Left err -> error err+    Right img -> return img      +    +  removeFile dot+  removeFile png  ++  return img+  +view :: String -> IO ()+view dot = do+  img <- convertToPNG dot+  swapMVar theImage (Just img)+  win <- readMVar theWindow+  postRedisplay (Just win)+  return ()+ +--------------------------------------------------------------------------------++setTexture :: IO ()+setTexture = do++  readMVar theImage >>= \m -> case m of +  +    Nothing -> return ()+    Just img -> do++      swapMVar theImage Nothing++      takeMVar theTexture >>= \m -> case m of+        Just (old,_) -> deleteObjectNames [old]+        Nothing -> return ()+    +      b <- readMVar npot+      let myWithImage = if b then withImage else withExtendedImage  +      +      tex <- myWithImage img $ \p (x,y) c -> do+    +        let (pf,pif) = case c of+          { 1 -> ( Luminance,      Luminance8       ) +          ; 2 -> ( LuminanceAlpha, Luminance8Alpha8 )+          ; 3 -> ( RGB,            RGB8             )+          ; 4 -> ( RGBA,           RGBA8            )+          }+        let size = TextureSize2D (fromIntegral x) (fromIntegral y) +            pdata = PixelData pf UnsignedByte p              +    +        [tex] <- genObjectNames 1 +    +        textureBinding Texture2D $= Just tex +        texImage2D Nothing NoProxy 0 pif size 0 pdata+        textureFilter Texture2D $= ((Linear',Nothing),Linear')+        return tex+      +      putMVar theTexture $ Just (tex,resolution img)+  ++--------------------------------------------------------------------------------++vt :: Double -> Double -> IO ()+vt x y = vertex (Vertex2 x y)++tc :: Double -> Double -> IO ()+tc x y = texCoord (TexCoord2 x y)++-- display callback  +display :: IO ()+display = do+  win <- readMVar theWindow +  currentWindow $= Just win+  +  clearColor $= Color4 0.90 0.90 0.90 1+  clear [ColorBuffer] ++  setTexture+  +  readMVar theTexture >>= \m -> case m of +    Nothing -> return ()+    Just (tex,(xsize,ysize)) -> do+        +      size@(Size xres yres) <- get windowSize+      viewport $= ( Position 0 0 , size )+      let winaspect = fromIntegral xres  / fromIntegral yres  :: Double+          picaspect = fromIntegral xsize / fromIntegral ysize :: Double+      matrixMode $= Projection >> loadIdentity+      ortho (-1) 1 (-1) 1 (-1) 1+              +      texture Texture2D $= Enabled+      textureBinding Texture2D $= Just tex+      b <- readMVar npot+      let (x,y) = if picaspect > winaspect then (1,winaspect/picaspect) else (picaspect/winaspect,1)+          myExtendDimension = if b then id else nextPowerOfTwo+          u = fromIntegral xsize / fromIntegral (myExtendDimension xsize) +          v = fromIntegral ysize / fromIntegral (myExtendDimension ysize) +      renderPrimitive Quads $ do +        tc 0 0 ; vt (-x) ( y)+        tc u 0 ; vt ( x) ( y)+        tc u v ; vt ( x) (-y)+        tc 0 v ; vt (-x) (-y)+         +  swapBuffers+  +--------------------------------------------------------------------------------+  +log2 :: Int -> Int+log2 n = case n of+  0 -> -1+  _ -> 1 + log2 (shiftR n 1) + +nextPowerOfTwo :: Int -> Int      +nextPowerOfTwo n = 2 ^ ( 1 + log2 (n-1) )+  +-- extend the image to have power-of-two sizes+withExtendedImage :: Image -> (Ptr Word8 -> (Int,Int) -> Int -> IO a) -> IO a+withExtendedImage img action = withImage img $ \p (oldx,oldy) c -> do+  let (newx,newy) = (nextPowerOfTwo oldx, nextPowerOfTwo oldy)+  +  allocaArray (newx*newy*c) $ \q -> do+    forM_ [0..oldy-1] $ \i -> copyArray +      (q `advancePtr` (i*c*newx))  -- destination +      (p `advancePtr` (i*c*oldx))  -- source+      (oldx*c)                     -- number of bytes+  +    action q (newx,newy) c+    +--------------------------------------------------------------------------------+  +-- reshape callback+reshape _ = postRedisplay Nothing+  +-- keyboard callback+keyboard key keyState mod pos = +  case key of +    Char '\ESC' -> exitWith ExitSuccess+    _ -> return ()    ++--------------------------------------------------------------------------------++theWindow :: MVar Window+theWindow = unsafePerformIO newEmptyMVar++npot :: MVar Bool+npot = unsafePerformIO newEmptyMVar++idle :: IO ()+idle = do  +  threadDelay 10000++ourInitialWinSize :: Size+ourInitialWinSize = Size 640 400++initGLUT :: IO ()+initGLUT = do+    +  initialDisplayMode $= [ RGBAMode, DoubleBuffered ]+  initialWindowSize $= ourInitialWinSize++  prog <- getProgName+  initialize prog [] +        +  win <- createWindow "vacuum-opengl-server"++  exts <- get glExtensions +  putMVar npot ("GL_ARB_texture_non_power_of_two" `elem` exts)++  displayCallback       $= display+  idleCallback          $= Just idle+  reshapeCallback       $= Just reshape+  keyboardMouseCallback $= Just keyboard++  drawBuffer $= BackBuffers+  postRedisplay (Just win)++  putMVar theWindow win+  +  mainLoop+    +--------------------------------------------------------------------------------+    +serverMain :: IO ()+serverMain = do+  +  args <- getArgs+  let port = case args of+        []    -> defaultPort+        (x:_) -> PortNumber $ fromIntegral $ (read x :: Int)++  forkOS (startServer port)+  +  initGLUT +    +--------------------------------------------------------------------------------+   

@@ -0,0 +1,56 @@+Name:                vacuum-opengl+Version:             0.0+Synopsis:            Visualize live Haskell data structures using vacuum, graphviz and OpenGL.+Description:         Visualize live Haskell data structures using vacuum, graphviz and OpenGL.+                     Intended as an easier-to-build alternative (no large dependency chain)+                     to vacuum-cairo. Because of severe problems with GHCi+GLUT, it is +                     implemented using a client-server architecture.+License:             PublicDomain+License-file:        LICENSE+Author:              Balazs Komuves+Maintainer:          bkomuves (plus) hackage (at) gmail (dot) com+Homepage:            http://code.haskell.org/~bkomuves/+Stability:           Experimental+Category:            Development+Tested-With:         GHC == 6.10.1 +Cabal-Version:       >= 1.2+Build-Type:          Simple++Flag base4+  Description: Base v4 ++Executable vacuum-opengl-server+  if flag(base4)+    Build-Depends:        base >= 4 && < 5, directory, process, network+    cpp-options:          -DBASE_MAJOR_VERSION=4+  else+    Build-Depends:        base >= 3 && < 4, directory, process, network+    cpp-options:          -DBASE_MAJOR_VERSION=3++  Build-Depends:       stb-image >= 0.1.3, OpenGL >= 2.2, GLUT >= 2.1+    +  Main-is:             ServerMain.hs+  Other-Modules:       System.Vacuum.OpenGL.Server+  +  Hs-Source-Dirs:      .+  Extensions:          CPP+  cpp-options:         -DVACUUM_OPENGL_DEFAULTPORT=55961+  ghc-options:         -Wall -threaded++Library+  if flag(base4)+    Build-Depends:        base >= 4 && < 5, pretty, network+    cpp-options:          -DBASE_MAJOR_VERSION=4+  else+    Build-Depends:        base >= 3 && < 4, pretty, network+    cpp-options:          -DBASE_MAJOR_VERSION=3++  Build-Depends:       vacuum >= 0.0.90+    +  Exposed-Modules:     System.Vacuum.OpenGL.Client,+                       System.Vacuum.OpenGL+  +  Hs-Source-Dirs:      .+  Extensions:          CPP+  cpp-options:         -DVACUUM_OPENGL_DEFAULTPORT=55961+  ghc-options:         -Wall