{- |

Module : $Header$

Copyright : (c) Uni Bremen 2003-2007

License : GPLv2 or higher, see LICENSE.txt

Maintainer : raider@informatik.uni-bremen.de

Stability : unstable

Portability : non-portable

This Modul provides a function to display a Library Dependency Graph.

-}

module GUI.ShowLibGraph

( showLibGraph

, mShowGraph

, closeOpenWindows

) where

import Driver.Options (HetcatsOpts (outtypes, verbose))

import Driver.ReadFn

import Driver.WriteFn

import Driver.AnaLib

import Static.ComputeTheory

import Static.DevGraph

import Static.History

import Static.ToXml as ToXml

import Static.ApplyChanges

import GUI.UDGUtils as UDG

import GUI.Utils

import GUI.GraphTypes

import GUI.GraphLogic (translateGraph, showDGraph)

import GUI.ShowLogicGraph (showLogicGraph)

import GUI.GraphDisplay

import qualified GUI.GraphAbstraction as GA

import Common.LibName

import qualified Common.Lib.Rel as Rel

import Common.Result

import Common.ResultT

import Common.XmlDiff

import Text.XML.Light

import Data.IORef

import qualified Data.Map as Map

import qualified Data.Set as Set

import Control.Concurrent.MVar

import Control.Monad

import Interfaces.DataTypes

import Interfaces.Utils

type NodeEdgeList = ([DaVinciNode LibName], [DaVinciArc (IO String)])

{- | Creates a new uDrawGraph Window and shows the Library Dependency Graph of

the given LibEnv. -}

showLibGraph :: LibFunc

showLibGraph gi = do

let lock = libGraphLock gi

isEmpty <- isEmptyMVar lock

when isEmpty $ do

putMVar lock ()

updateWindowCount gi succ

graph <- newIORef daVinciSort

nodesEdges <- newIORef (([], []) :: NodeEdgeList)

let

globalMenu =

GlobalMenu (UDG.Menu Nothing

[ Button "Reload Library" $ reloadLibGraph gi graph nodesEdges

, Button "Experimental reload changed Library"

$ changeLibGraph gi graph nodesEdges

, Button "Translate Library" $ translate gi

, Button "Show Logic Graph" $ showLogicGraph daVinciSort

])

graphParms = globalMenu $$

GraphTitle "Library Graph" $$

OptimiseLayout True $$

AllowClose (closeGInfo gi) $$

FileMenuAct ExitMenuOption (Just (exitGInfo gi)) $$

emptyGraphParms

graph' <- newGraph daVinciSort graphParms

addNodesAndEdges gi graph graph' nodesEdges

closeGInfo :: GInfo -> IO Bool

closeGInfo gi = do

updateWindowCount gi pred

takeMVar (libGraphLock gi)

return True

-- | Reloads all Libraries and the Library Dependency Graph

reloadLibGraph :: GInfo -> IORef DaVinciGraphTypeSyn -> IORef NodeEdgeList

-> IO ()

reloadLibGraph gi graph nodesEdges = do

b <- warningDialog "Reload library" warnTxt

when b $ reloadLibGraph' gi graph nodesEdges

warnTxt :: String

warnTxt = unlines

[ "Are you sure to recreate Library?"

, "All development graph windows will be closed and proofs will be lost."

, "", "This operation can not be undone." ]

-- | Reloads all Libraries and the Library Dependency Graph

reloadLibGraph' :: GInfo -> IORef DaVinciGraphTypeSyn -> IORef NodeEdgeList

-> IO ()

reloadLibGraph' gi graph nodesEdges = do

graph' <- readIORef graph

(nodes, edges) <- readIORef nodesEdges

let ln = libName gi

libfile = libNameToFile ln

m <- anaLib (hetcatsOpts gi) { outtypes = [] } libfile

case m of

Nothing -> errorDialog "Error" $ "Error when reloading file '"

++ libfile ++ "'"

Just (_, le) -> do

closeOpenWindows gi

mapM_ (deleteArc graph') edges

mapM_ (deleteNode graph') nodes

addNodesAndEdges gi graph graph' nodesEdges

writeIORef (intState gi) emptyIntState

{ i_state = Just $ emptyIntIState le ln

, filename = libfile }

mShowGraph gi ln

changeLibGraph :: GInfo -> IORef DaVinciGraphTypeSyn -> IORef NodeEdgeList

-> IO ()

changeLibGraph gi graph nodesEdges = do

let ln = libName gi

opts = hetcatsOpts gi

ost <- readIORef $ intState gi

graph' <- readIORef graph

(nodes, edges) <- readIORef nodesEdges

case i_state ost of

Nothing -> return ()

Just ist -> do

let le = i_libEnv ist

dg = lookupDGraph ln le

fn = libNameToFile ln

dgold = undoAllChanges dg

olk = getNewEdgeId dgold

c2 = ToXml.dGraph le ln dgold

m <- anaLib opts { outtypes = [] } fn

case m of

Just (nln, nle) | nln == ln -> do

let dg2 = lookupDGraph nln nle

ndg = undoAllChanges dg2

c3 = ToXml.dGraph nle ln ndg

xs = hetsXmlDiff c2 c3

rdg = foldr (\ (_, _, l) xdg -> let i = dgl_id l in

if i >= olk then

renumberDGLink i (getNewEdgeId xdg) xdg else xdg) dg

{ getNewEdgeId = max (getNewEdgeId ndg) (getNewEdgeId dg) }

$ labEdgesDG dg

writeVerbFile opts (libNameToFile ln ++ ".xupdate")

$ ppTopElement xs

Result ds mdg <- runResultT $ dgXUpdateMods opts c2 xs le ln rdg

case mdg of

Just (nLn, fle) -> do

closeOpenWindows gi

mapM_ (deleteArc graph') edges

mapM_ (deleteNode graph') nodes

addNodesAndEdges gi graph graph' nodesEdges

writeIORef (intState gi) emptyIntState

{ i_state = Just $ emptyIntIState fle nLn

, filename = fn }

mShowGraph gi nLn

Nothing ->

errorDialog "Error" $ showRelDiags (verbose opts) ds

_ -> errorDialog "Error" $ "Error when reloading file '" ++ fn ++ "'"

-- | Translate Graph

translate :: GInfo -> IO ()

translate gi = do

b <- warningDialog "Translate library" warnTxt

when b $ translate' gi

-- | Translate Graph

translate' :: GInfo -> IO ()

translate' gi = do

mle <- translateGraph gi

case mle of

Just le -> do

closeOpenWindows gi

let ln = libName gi

ost = emptyIntState

nwst = case i_state ost of

Nothing -> ost

Just ist -> ost { i_state = Just $ ist { i_libEnv = le

, i_ln = ln }

, filename = libNameToFile ln }

writeIORef (intState gi) nwst

mShowGraph gi ln

Nothing -> return ()

-- | closes the open graphs to be reopened later

closeOpenWindows :: GInfo -> IO ()

closeOpenWindows gi = do

let iorOpenGraphs = openGraphs gi

oGraphs <- readIORef iorOpenGraphs

mapM_ (GA.closeGraphWindow . graphInfo) $ Map.elems oGraphs

updateWindowCount gi (const 1)

writeIORef iorOpenGraphs Map.empty

-- | Adds the Librarys and the Dependencies to the Graph

addNodesAndEdges :: GInfo -> IORef DaVinciGraphTypeSyn -> DaVinciGraphTypeSyn

-> IORef NodeEdgeList -> IO ()

addNodesAndEdges gi graphR graph nodesEdges = do

ost <- readIORef $ intState gi

case i_state ost of

Nothing -> return ()

Just ist -> do

let

le = i_libEnv ist

opts = hetcatsOpts gi

lookup' x y = Map.findWithDefault

(error $ "lookup2': node not found " ++ show y) y x

keySet = Map.keysSet le

keys = Set.toList keySet

subNodeMenu = LocalMenu (UDG.Menu Nothing [

Button "Show Graph" $ mShowGraph gi,

Button "Show spec/View Names" $ showSpec le])

subNodeTypeParms = subNodeMenu $$$

Box $$$

ValueTitle (return . show) $$$

Color (getColor opts Green True True) $$$

emptyNodeTypeParms

subNodeType <- newNodeType graph subNodeTypeParms

subNodeList <- mapM (newNode graph subNodeType) keys

let

nodes' = Map.fromList $ zip keys subNodeList

subArcMenu = LocalMenu (UDG.Menu Nothing [])

subArcTypeParms = subArcMenu $$$

ValueTitle id $$$

Color (getColor opts Black False False) $$$

emptyArcTypeParms

subArcType <- newArcType graph subArcTypeParms

let insertSubArc (node1, node2) = newArc graph subArcType (return "")

(lookup' nodes' node1)

(lookup' nodes' node2)

subArcList <- mapM insertSubArc $ getLibDeps keySet le

writeIORef nodesEdges (subNodeList, subArcList)

writeIORef graphR graph

redraw graph

-- | Creates a list of all LibName pairs, which have a dependency

getLibDeps :: Set.Set LibName -> LibEnv -> [(LibName, LibName)]

getLibDeps ks =

Rel.toList . Rel.intransKernel . (`Rel.restrict` ks) . getLibDepRel

mShowGraph :: GInfo -> LibName -> IO ()

mShowGraph gi ln = showDGraph gi ln convertGraph showLibGraph

-- | Displays the Specs of a Library in a Textwindow

showSpec :: LibEnv -> LibName -> IO ()

showSpec le ln =

createTextDisplay ("Contents of " ++ show ln)

$ unlines . map show . Map.keys . globalEnv

$ lookupDGraph ln le