import Paths_visual_graphrewrite (version) import GraphRewrite.Internal.Convert import GraphRewrite.Internal.Rename import GraphRewrite.Internal.RewriteApp import GraphRewrite.Internal.RewriteTypes import GraphRewrite.Internal.DeltaFunctions import GraphRewrite.Main.CmdLineOpts import GraphRewrite.Main.Visualize import qualified Graphics.UI.Gtk as G import qualified Graphics.UI.Gtk.Gdk.Events as G import qualified Graphics.Rendering.Cairo as C import qualified Graphics.Rendering.Cairo.SVG as C import Text.PrettyPrint import Data.Graph.Inductive hiding (version) import Language.Haskell.Parser -- parseModule import IPPrint --pprint import System.Environment --getArgs import Data.Supply import qualified Data.Version import qualified Data.Map as D import qualified Data.IntMap as I import System.Process import Control.Concurrent (forkIO, yield) import System.IO import Control.Monad import System.Exit import qualified Control.Exception as C import Control.Parallel.Strategies import System.IO.Unsafe import Control.Concurrent.MVar.Strict import System.Directory import Prelude hiding (exp) data Session = Session { sWindow :: !G.Window, sDrawing :: !G.DrawingArea, sSVGs :: ![C.SVG], cur :: !Int } instance NFData Session where rnf x = x `seq` () predef :: [String] predef = map snd deltaNames main :: IO () main = do args <- getArgs options <- parseOptions args if showVersion options then putStrLn $ "version " ++ Data.Version.showVersion version else do tmp <- readInput (inputFile options) let mod = parseModule tmp --pprint $ mod --putStrLn "-------------------------------------------------------------------------" pprint $ convParse $ mod ids <- newEnumSupply let (ids1, ids2, ids3) = split3 ids let (Ok (predefBinds,_,_)) = distributeIds predef ids2 let (Ok (n,m)) = rename' predefBinds (convParse $parseModule tmp) ids1 let rs = makeRewriteSystem m n pprint rs let pgs = map (\x -> (exp x, graph x)) $ concat $ map snd $ I.toList $ rules rs let grs = map (\(x,y) -> graphToGr x rs y) (zip (split ids3) pgs) G.timeoutAddFull (yield >> return True) G.priorityDefaultIdle 50 -- magic, do not touch mapM_ addToSession grs {- case rename' predefBinds (convParse $ parseModule tmp) ids1 of Ok (n,m) -> pprint m >> pprint n >> pprint (invRename n m) >> pprint (makeRewriteRules m) Hiba f -> pprint$ "HIBA: " ++ f -} readInput :: Maybe String -> IO String readInput Nothing = getContents readInput (Just f) = readFile f nextSVG :: Session -> Session nextSVG s@(Session _ _ svgs i) | i+1 >= length svgs = s { cur = 1 } | otherwise = s { cur = i+1 } prevSVG :: Session -> Session prevSVG s@(Session _ _ svgs i) | i <= 1 = s { cur = (length svgs) - 1 } | otherwise = s { cur = i - 1 } addToSession :: Gr String String -> IO Int addToSession gr = do noSession <- isEmptyMVar sessionRef () <- when noSession $ newSession let dot = render $ ppGr gr mdot <- findExecutable "dot" let exe = case mdot of Nothing -> error "dot binary not found. Please install graphviz" Just p -> p svgstring <- myReadProcess exe ["-Tsvg"] dot svg <- C.svgNewFromString svgstring modifyMVar sessionRef $ \(Session w c svgs i) -> return ((Session w c (svgs ++ [svg]) i), length svgs) view :: Gr String String -> IO () view gr = do i <- addToSession gr c <- modifyMVar sessionRef $ \(Session win canvas svgs _cur) -> do updateCanvas (svgs !! i) canvas return ((Session win canvas svgs i), canvas) G.widgetQueueDraw c yield return () updateCanvas :: C.SVG -> G.DrawingArea -> IO Bool updateCanvas svg canvas = do win <- G.widgetGetDrawWindow canvas (width, height) <- G.widgetGetSize canvas let (w,h) = (fromIntegral width, fromIntegral height) (sw, sh) = C.svgGetSize svg G.renderWithDrawable win $ do C.setAntialias C.AntialiasDefault C.setLineCap C.LineCapSquare C.scale (w / fromIntegral sw) (h / fromIntegral sh) C.svgRender svg return True myReadProcess :: FilePath -- ^ command to run -> [String] -- ^ any arguments -> String -- ^ standard input -> IO String -- ^ stdout + stderr myReadProcess cmd args input = do (Just inh, Just outh, _, pid) <- createProcess (proc cmd args){ std_in = CreatePipe, std_out = CreatePipe, std_err = Inherit } -- fork off a thread to start consuming the output output <- hGetContents outh outMVar <- newEmptyMVar forkIO $ C.evaluate (length output) >> putMVar outMVar () -- now write and flush any input when (not (null input)) $ do hPutStr inh input; hFlush inh hClose inh -- done with stdin -- wait on the output takeMVar outMVar hClose outh -- wait on the process ex <- waitForProcess pid case ex of ExitSuccess -> return output ExitFailure _ -> return output handleKeys :: (Monad m, G.WidgetClass w) => D.Map String (w -> m a) -> w -> G.Event -> m Bool handleKeys m w (G.Key {G.eventKeyName = key}) = case D.lookup key m of Just a -> (a w) >> return True _ -> return True keyBindings :: (G.WidgetClass w) => D.Map String (w -> IO ()) keyBindings = D.fromList [("q", G.widgetDestroy) ,("space", const $ do modifyMVar_ sessionRef (return . nextSVG) withMVar sessionRef $ \(Session _ c svgs cur) -> updateCanvas (svgs !! cur) c return () ) ,("BackSpace", const $ do modifyMVar_ sessionRef (return . prevSVG) withMVar sessionRef $ \(Session _ c svgs cur) -> updateCanvas (svgs !! cur) c return () ) ] sessionRef :: MVar a sessionRef = unsafePerformIO $ newEmptyMVar {-# NOINLINE sessionRef #-} newSession :: IO () newSession = do G.unsafeInitGUIForThreadedRTS window <- G.windowNew canvas <- G.drawingAreaNew svg <- C.svgNewFromString welcome G.onKeyPress window $ handleKeys keyBindings window G.onDestroy window (takeMVar sessionRef >> G.mainQuit) G.onExposeRect canvas $ const $ do withMVar sessionRef $ \(Session _ c svgs cur) -> updateCanvas (svgs !! cur) c return () G.set window [G.containerChild G.:= canvas] G.windowSetDefaultSize window 400 400 G.widgetShowAll window forkIO G.mainGUI let s = Session { sWindow = window, sDrawing = canvas, sSVGs = [svg], cur = 0 } putMVar sessionRef $! s welcome :: String welcome = unlines ["" ,"" ,"" ," " ," " ," " ," " ," " ," " ," " ," image/svg+xml" ," " ," " ," " ," " ," " ," " ," " ," " ,"" ]