import Paths_visual_graphrewrite (version, getDataFileName)
import GraphRewrite
import GraphRewrite.Main.Welcome
import GraphRewrite.Main.CmdLineOpts
import GraphRewrite.Main.Utils
import GraphRewrite.Main.Visualize
import qualified Graphics.UI.Gtk as G
import qualified Graphics.UI.Gtk.Glade as G
import qualified Graphics.Rendering.Cairo.SVG as C
import Data.GraphViz
import Language.Haskell.Parser -- parseModule
import IPPrint --pprint
import System.Environment --getArgs
import Data.Supply
import qualified Data.Version
import qualified Data.IntMap as I
import Data.Maybe
import Control.Concurrent (forkIO, yield)
import Control.Arrow hiding (left)
import Control.Monad
import Control.Parallel.Strategies
import Control.Concurrent.MVar.Strict
import System.Directory
import Prelude hiding (exp)
--------------------------------------
data State = State
{ current :: RewriteTree
, history :: Context
, rewrsys :: RewriteSystem
, idsupp :: Supply Int
, sWindow :: G.Window
, sDrawing :: G.DrawingArea
, sMap :: G.DrawingArea
, dotexe :: FilePath
, opts :: Options
}
instance NFData State where
rnf = flip 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 sh = convParse $ parseModuleWithMode (ParseMode (fromMaybe "stdin" $ inputFile options)) tmp
when (debug options) $ pprint sh
ids <- newEnumSupply
let (deltaIds: ids1: ids2: ids3:_) = split ids
let (Ok (predefBinds,_,_)) = distributeIds predef deltaIds -- distribute delta function ids
case rename' predefBinds sh ids2 of -- scope analysis
Error f -> error $ "Error: " ++ f
Ok (names,module_) -> do
let rs = makeRewriteSystem module_ names
when (debug options) $ pprint rs
let rewritetree = case mainTerm options of
Nothing -> startRuleDefs rs
Just tm -> startRewriting tm rs ids3
mstate <- newState options rs ids1 rewritetree
runGUI mstate
-- configureWindow basicKeyBindings mstate msession
cleanup :: MVar State -> IO ()
cleanup mstate = do
takeMVar mstate
G.mainQuit
configureBindings :: G.GladeXML -> MVar State -> IO ()
configureBindings xml mstate = do
window <- G.xmlGetWidget xml G.castToWindow "visual-graphrewrite"
quitbutton <- G.xmlGetWidget xml G.castToButton "quitbutton"
leftbutton <- G.xmlGetWidget xml G.castToButton "leftbutton"
rightbutton <- G.xmlGetWidget xml G.castToButton "rightbutton"
upbutton <- G.xmlGetWidget xml G.castToButton "upbutton"
downbutton <- G.xmlGetWidget xml G.castToButton "downbutton"
aboutmenu <- G.xmlGetWidget xml G.castToImageMenuItem "aboutmenuitem"
quitmenu <- G.xmlGetWidget xml G.castToImageMenuItem "quitmenuitem"
aboutwidget <- G.xmlGetWidget xml G.castToAboutDialog "aboutdialog"
G.onClicked quitbutton $ G.widgetDestroy window
G.onActivateLeaf quitmenu $ G.widgetDestroy window
G.onClicked leftbutton $ moveLeft mstate >> refresh mstate >> return ()
G.onClicked rightbutton $ moveRight mstate >> refresh mstate >> return ()
G.onClicked upbutton $ moveUp mstate >> refresh mstate >> return ()
G.onClicked downbutton $ moveDown mstate >> refresh mstate >> return ()
G.onActivateLeaf aboutmenu $ G.dialogRun aboutwidget >> return ()
return ()
runGUI :: MVar State -> IO ()
runGUI mstate = do
G.initGUI
uipath <- getDataFileName "ui.glade"
Just xml <- G.xmlNew uipath
window <- G.xmlGetWidget xml G.castToWindow "visual-graphrewrite"
G.onDestroy window (cleanup mstate)
canvas <- G.xmlGetWidget xml G.castToDrawingArea "drawingarea"
maparea <- G.xmlGetWidget xml G.castToDrawingArea "map"
modifyMVar_ mstate $ \ state ->
return state { sWindow = window, sDrawing = canvas, sMap = maparea }
configureBindings xml mstate
G.widgetShowAll window
G.timeoutAddFull (yield >> return True) G.priorityDefaultIdle 50
forkIO G.mainGUI
svg <- C.svgNewFromString welcome
updateCanvas svg canvas
G.onExposeRect canvas (const $ refresh mstate >> return ())
G.onExposeRect maparea (const $ refresh mstate >> return ())
return ()
startRewriting :: String -> RewriteSystem -> Supply Int -> RewriteTree
startRewriting term rs ids = tree
where
tree = rewriteStepFine rs expr gra
gra = I.fromList []
binds = namesToBinds (names rs)
sh = rename' binds (convParse $ parseModuleWithMode (ParseMode "CmdLine Argument") ("tHiSiSaVeRyBaDaNDuGLyHaCK = " ++ term)) ids
expr = case sh of
Ok (_, m) -> exp $ head $ I.findMin $ rules $ makeRewriteRules m
Error err -> error $ "Error during parsing CmdLine argument: " ++ err
{-case I.toList (I.filter (== term) (names rs)) of
[(tid, _)] -> case I.lookup tid (rules rs) of
Just [r] -> (exp r, graph r)
Just _ -> error $ "Ambiguous reference to term: " ++ term ++ ". Make sure there is only one rule associated with it in the source file. (Maybe you want to examine another term?)"
Nothing -> error $ "No such term `" ++ term ++ "' found in the source file, it is probably defined elsewhere. (Did you want to examine a delta function?)"
[] -> error $ "Absolutely nothing found about this term: " ++ term ++ ". You probably have a typo somewhere."
_ -> error $ "Ambiguous reference to term: " ++ term ++ ". This shouldn't happen if your source file compiles with a Haskell compiler."
-}
startRuleDefs :: RewriteSystem -> RewriteTree
startRuleDefs rs = tree
where
tree = Step start pgtrees
start = (SLit "Move down to see rule definitions", I.fromList [])
pgs = map (exp &&& graph) $ concatMap snd $ I.toList $ rules rs
pgtrees = map (\pg -> Step pg []) pgs
moveDown :: MVar State -> IO ()
moveDown = flip modifyMVar_ $ \ state ->
case current state of
Step _ [] -> return state
Step g (h:t) -> return state { current = h
, history = RewriteBranch g [] t : history state
}
moveUp :: MVar State -> IO ()
moveUp = flip modifyMVar_ $ \ state ->
case history state of
[] -> return state
(h:t) -> return state { current = Step (node h) (left h ++ [current state] ++ rght h)
, history = t
}
moveRight :: MVar State -> IO ()
moveRight = flip modifyMVar_ $ \ state ->
case history state of
[] -> return state
(RewriteBranch _ _ []:_) -> return state
(RewriteBranch n l (rh:rt):t) ->
return state { current = rh
, history = RewriteBranch n (current state : l) rt : t
}
moveLeft :: MVar State -> IO ()
moveLeft = flip modifyMVar_ $ \ state ->
case history state of
[] -> return state
(RewriteBranch _ [] _ : _) -> return state
(RewriteBranch n (lh:lt) r : t) ->
return state { current = lh
, history = RewriteBranch n lt (current state : r) : t
}
refresh :: MVar State -> IO Bool
refresh mstate = do
state <- takeMVar mstate
let (ids, ids') = split2 (idsupp state)
putMVar mstate (state { idsupp = ids' })
let (Step pg _) = current state
when (debug $ opts state) (putStr "DEBUG: " >> pprint pg)
updateCanvasTo (sDrawing state) pg (dotexe state) (rewrsys state) ids
dg <- stateToDot (current state) (history state)
when (debug $ opts state) (putStrLn $ "DEBUG: isValidGraph: " ++ (show $ isValidGraph dg))
when (debug $ opts state) (putStrLn $ "DEBUG: " ++ show dg)
svgmap <- dotToSVG (dotexe state) (show dg)
updateCanvas svgmap (sMap state)
newState :: Options -> RewriteSystem -> Supply Int -> RewriteTree -> IO (MVar State)
newState opts rs ids tree = do
mdot <- findExecutable "dot"
let exe = case mdot of
Nothing -> error "dot binary not found. Please install graphviz"
Just p -> p
let s = State { history = []
, current = tree
, rewrsys = rs
, idsupp = ids
, opts = opts
, dotexe = exe
}
newMVar s