diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/ServerMain.hs b/ServerMain.hs new file mode 100644 --- /dev/null +++ b/ServerMain.hs @@ -0,0 +1,7 @@ + +module Main where + +import System.Vacuum.OpenGL.Server + +main :: IO () +main = serverMain diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,5 @@ +#! /usr/bin/env runhaskell +> +> import Distribution.Simple +> main = defaultMain +> diff --git a/System/Vacuum/OpenGL.hs b/System/Vacuum/OpenGL.hs new file mode 100644 --- /dev/null +++ b/System/Vacuum/OpenGL.hs @@ -0,0 +1,7 @@ + +module System.Vacuum.OpenGL + ( module System.Vacuum.OpenGL.Client + ) + where + +import System.Vacuum.OpenGL.Client diff --git a/System/Vacuum/OpenGL/Client.hs b/System/Vacuum/OpenGL/Client.hs new file mode 100644 --- /dev/null +++ b/System/Vacuum/OpenGL/Client.hs @@ -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) + +-------------------------------------------------------------------------------- + diff --git a/System/Vacuum/OpenGL/Server.hs b/System/Vacuum/OpenGL/Server.hs new file mode 100644 --- /dev/null +++ b/System/Vacuum/OpenGL/Server.hs @@ -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 + +-------------------------------------------------------------------------------- + diff --git a/vacuum-opengl.cabal b/vacuum-opengl.cabal new file mode 100644 --- /dev/null +++ b/vacuum-opengl.cabal @@ -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