{- |
Module      :  ./GUI/ShowRefTree.hs
Copyright   :  (c) Mihai Codescu, DFKI GmbH 2010
License     :  GPLv2 or higher, see LICENSE.txt

Maintainer  :  mihai.codescu@dfki.de
Stability   :  provisional
Portability :  non-portable (Logic)

display the logic graph
-}

module GUI.ShowRefTree (showRefTree) where

import Control.Monad

import Data.Graph.Inductive.Graph as Tree
import Data.IORef

import GUI.GraphTypes
import GUI.UDGUtils as UDG
import GUI.Utils
import GUI.GraphLogic

import Interfaces.DataTypes
import Interfaces.Command
import Common.Consistency
import Common.DocUtils
import Driver.Options (doDump)

import Static.DevGraph
import Static.DgUtils
import Static.PrintDevGraph
import Static.History

import qualified Data.Map as Map
import qualified Data.Set as Set
import Data.Char

lookup' :: (Ord a) => Map.Map a b -> a -> b
lookup' :: Map a b -> a -> b
lookup' x :: Map a b
x y :: a
y = b -> a -> Map a b -> b
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault ([Char] -> b
forall a. HasCallStack => [Char] -> a
error "lookup': key not found") a
y Map a b
x

showRefTree :: LibFunc
showRefTree :: LibFunc
showRefTree gInfo :: GInfo
gInfo = do
  IntState
ost <- IORef IntState -> IO IntState
forall a. IORef a -> IO a
readIORef (IORef IntState -> IO IntState) -> IORef IntState -> IO IntState
forall a b. (a -> b) -> a -> b
$ GInfo -> IORef IntState
intState GInfo
gInfo
  case IntState -> Maybe IntIState
i_state IntState
ost of
    Nothing -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Just ist :: IntIState
ist -> do
     let
      le :: LibEnv
le = IntIState -> LibEnv
i_libEnv IntIState
ist
      dg :: DGraph
dg = LibEnv -> LibName -> DGraph
forall a b. Ord a => Map a b -> a -> b
lookup' LibEnv
le (LibName -> DGraph) -> LibName -> DGraph
forall a b. (a -> b) -> a -> b
$ IntIState -> LibName
i_ln IntIState
ist
     Maybe Int
sel <- [Char] -> [[Char]] -> IO (Maybe Int)
listBox "Choose a specification" ([[Char]] -> IO (Maybe Int)) -> [[Char]] -> IO (Maybe Int)
forall a b. (a -> b) -> a -> b
$ Map [Char] [Int] -> [[Char]]
forall k a. Map k a -> [k]
Map.keys (Map [Char] [Int] -> [[Char]]) -> Map [Char] [Int] -> [[Char]]
forall a b. (a -> b) -> a -> b
$ DGraph -> Map [Char] [Int]
specRoots DGraph
dg
     case Maybe Int
sel of
       Nothing -> [Char] -> [Char] -> IO ()
errorDialog "Error" "no specification chosen"
       Just i :: Int
i -> do 
        let rspName :: [Char]
rspName = (Map [Char] [Int] -> [[Char]]
forall k a. Map k a -> [k]
Map.keys (Map [Char] [Int] -> [[Char]]) -> Map [Char] [Int] -> [[Char]]
forall a b. (a -> b) -> a -> b
$ DGraph -> Map [Char] [Int]
specRoots DGraph
dg) [[Char]] -> Int -> [Char]
forall a. [a] -> Int -> a
!! Int
i
        [Char] -> [Int] -> LibFunc
showRefTreeAux [Char]
rspName 
            (Map [Char] [Int] -> [Char] -> [Int]
forall a b. Ord a => Map a b -> a -> b
lookup' (DGraph -> Map [Char] [Int]
specRoots DGraph
dg) [Char]
rspName)
            GInfo
gInfo

showRefTreeAux :: String -> [Int] -> LibFunc
showRefTreeAux :: [Char] -> [Int] -> LibFunc
showRefTreeAux rspName :: [Char]
rspName roots :: [Int]
roots gInfo :: GInfo
gInfo = do
    IORef
  (Graph
     DaVinciGraph
     DaVinciGraphParms
     DaVinciNode
     DaVinciNodeType
     DaVinciNodeTypeParms
     DaVinciArc
     DaVinciArcType
     DaVinciArcTypeParms)
graph <- Graph
  DaVinciGraph
  DaVinciGraphParms
  DaVinciNode
  DaVinciNodeType
  DaVinciNodeTypeParms
  DaVinciArc
  DaVinciArcType
  DaVinciArcTypeParms
-> IO
     (IORef
        (Graph
           DaVinciGraph
           DaVinciGraphParms
           DaVinciNode
           DaVinciNodeType
           DaVinciNodeTypeParms
           DaVinciArc
           DaVinciArcType
           DaVinciArcTypeParms))
forall a. a -> IO (IORef a)
newIORef Graph
  DaVinciGraph
  DaVinciGraphParms
  DaVinciNode
  DaVinciNodeType
  DaVinciNodeTypeParms
  DaVinciArc
  DaVinciArcType
  DaVinciArcTypeParms
daVinciSort
    IORef NodeEdgeListRef
nodesEdges <- NodeEdgeListRef -> IO (IORef NodeEdgeListRef)
forall a. a -> IO (IORef a)
newIORef (([], []) :: NodeEdgeListRef)
    let
      globalMenu :: GlobalMenu
globalMenu =
        MenuPrim (Maybe [Char]) (IO ()) -> GlobalMenu
GlobalMenu (Maybe [Char]
-> [MenuPrim (Maybe [Char]) (IO ())]
-> MenuPrim (Maybe [Char]) (IO ())
forall subMenuValue value.
subMenuValue
-> [MenuPrim subMenuValue value] -> MenuPrim subMenuValue value
UDG.Menu Maybe [Char]
forall a. Maybe a
Nothing
          [])
      graphParms :: DaVinciGraphParms
graphParms = GlobalMenu
globalMenu GlobalMenu -> DaVinciGraphParms -> DaVinciGraphParms
forall option configuration.
HasConfig option configuration =>
option -> configuration -> configuration
$$
                   [Char] -> GraphTitle
GraphTitle ("Refinement Tree of " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
rspName) GraphTitle -> DaVinciGraphParms -> DaVinciGraphParms
forall option configuration.
HasConfig option configuration =>
option -> configuration -> configuration
$$
                   Bool -> OptimiseLayout
OptimiseLayout Bool
True OptimiseLayout -> DaVinciGraphParms -> DaVinciGraphParms
forall option configuration.
HasConfig option configuration =>
option -> configuration -> configuration
$$
                   IO Bool -> AllowClose
AllowClose (Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True) AllowClose -> DaVinciGraphParms -> DaVinciGraphParms
forall option configuration.
HasConfig option configuration =>
option -> configuration -> configuration
$$
                   DaVinciGraphParms
forall graphParms. GraphParms graphParms => graphParms
emptyGraphParms
    Graph
  DaVinciGraph
  DaVinciGraphParms
  DaVinciNode
  DaVinciNodeType
  DaVinciNodeTypeParms
  DaVinciArc
  DaVinciArcType
  DaVinciArcTypeParms
graph' <- Graph
  DaVinciGraph
  DaVinciGraphParms
  DaVinciNode
  DaVinciNodeType
  DaVinciNodeTypeParms
  DaVinciArc
  DaVinciArcType
  DaVinciArcTypeParms
-> DaVinciGraphParms
-> IO
     (Graph
        DaVinciGraph
        DaVinciGraphParms
        DaVinciNode
        DaVinciNodeType
        DaVinciNodeTypeParms
        DaVinciArc
        DaVinciArcType
        DaVinciArcTypeParms)
forall graph graphParms (node :: * -> *) (nodeType :: * -> *)
       (nodeTypeParms :: * -> *) (arc :: * -> *) (arcType :: * -> *)
       (arcTypeParms :: * -> *).
GraphAll
  graph
  graphParms
  node
  nodeType
  nodeTypeParms
  arc
  arcType
  arcTypeParms =>
Graph
  graph
  graphParms
  node
  nodeType
  nodeTypeParms
  arc
  arcType
  arcTypeParms
-> graphParms
-> IO
     (Graph
        graph
        graphParms
        node
        nodeType
        nodeTypeParms
        arc
        arcType
        arcTypeParms)
newGraph Graph
  DaVinciGraph
  DaVinciGraphParms
  DaVinciNode
  DaVinciNodeType
  DaVinciNodeTypeParms
  DaVinciArc
  DaVinciArcType
  DaVinciArcTypeParms
daVinciSort DaVinciGraphParms
graphParms
    GInfo
-> Graph
     DaVinciGraph
     DaVinciGraphParms
     DaVinciNode
     DaVinciNodeType
     DaVinciNodeTypeParms
     DaVinciArc
     DaVinciArcType
     DaVinciArcTypeParms
-> IORef NodeEdgeListRef
-> [Int]
-> IO ()
addNodesAndEdgesRef GInfo
gInfo Graph
  DaVinciGraph
  DaVinciGraphParms
  DaVinciNode
  DaVinciNodeType
  DaVinciNodeTypeParms
  DaVinciArc
  DaVinciArcType
  DaVinciArcTypeParms
graph' IORef NodeEdgeListRef
nodesEdges [Int]
roots
    IORef
  (Graph
     DaVinciGraph
     DaVinciGraphParms
     DaVinciNode
     DaVinciNodeType
     DaVinciNodeTypeParms
     DaVinciArc
     DaVinciArcType
     DaVinciArcTypeParms)
-> Graph
     DaVinciGraph
     DaVinciGraphParms
     DaVinciNode
     DaVinciNodeType
     DaVinciNodeTypeParms
     DaVinciArc
     DaVinciArcType
     DaVinciArcTypeParms
-> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef
  (Graph
     DaVinciGraph
     DaVinciGraphParms
     DaVinciNode
     DaVinciNodeType
     DaVinciNodeTypeParms
     DaVinciArc
     DaVinciArcType
     DaVinciArcTypeParms)
graph Graph
  DaVinciGraph
  DaVinciGraphParms
  DaVinciNode
  DaVinciNodeType
  DaVinciNodeTypeParms
  DaVinciArc
  DaVinciArcType
  DaVinciArcTypeParms
graph'
    Graph
  DaVinciGraph
  DaVinciGraphParms
  DaVinciNode
  DaVinciNodeType
  DaVinciNodeTypeParms
  DaVinciArc
  DaVinciArcType
  DaVinciArcTypeParms
-> IO ()
forall graph graphParms (node :: * -> *) (nodeType :: * -> *)
       (nodeTypeParms :: * -> *) (arc :: * -> *) (arcType :: * -> *)
       (arcTypeParms :: * -> *).
GraphAll
  graph
  graphParms
  node
  nodeType
  nodeTypeParms
  arc
  arcType
  arcTypeParms =>
Graph
  graph
  graphParms
  node
  nodeType
  nodeTypeParms
  arc
  arcType
  arcTypeParms
-> IO ()
redraw Graph
  DaVinciGraph
  DaVinciGraphParms
  DaVinciNode
  DaVinciNodeType
  DaVinciNodeTypeParms
  DaVinciArc
  DaVinciArcType
  DaVinciArcTypeParms
graph'

type NodeEdgeListRef = ([DaVinciNode Int], [DaVinciArc (IO RTLinkLab)])
type NodeEdgeListDep = ([DaVinciNode DiagNodeLab], [DaVinciArc (IO String)])

addNodesAndEdgesRef :: GInfo -> DaVinciGraphTypeSyn ->
                       IORef NodeEdgeListRef -> [Int] -> IO ()
addNodesAndEdgesRef :: GInfo
-> Graph
     DaVinciGraph
     DaVinciGraphParms
     DaVinciNode
     DaVinciNodeType
     DaVinciNodeTypeParms
     DaVinciArc
     DaVinciArcType
     DaVinciArcTypeParms
-> IORef NodeEdgeListRef
-> [Int]
-> IO ()
addNodesAndEdgesRef gInfo :: GInfo
gInfo@(GInfo { hetcatsOpts :: GInfo -> HetcatsOpts
hetcatsOpts = HetcatsOpts
opts}) graph :: Graph
  DaVinciGraph
  DaVinciGraphParms
  DaVinciNode
  DaVinciNodeType
  DaVinciNodeTypeParms
  DaVinciArc
  DaVinciArcType
  DaVinciArcTypeParms
graph nodesEdges :: IORef NodeEdgeListRef
nodesEdges roots :: [Int]
roots = do
 IntState
ost <- IORef IntState -> IO IntState
forall a. IORef a -> IO a
readIORef (IORef IntState -> IO IntState) -> IORef IntState -> IO IntState
forall a b. (a -> b) -> a -> b
$ GInfo -> IORef IntState
intState GInfo
gInfo
 case IntState -> Maybe IntIState
i_state IntState
ost of
  Nothing -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  Just ist :: IntIState
ist -> do
   let
    le :: LibEnv
le = IntIState -> LibEnv
i_libEnv IntIState
ist
    dg :: DGraph
dg = LibEnv -> LibName -> DGraph
forall a b. Ord a => Map a b -> a -> b
lookup' LibEnv
le (LibName -> DGraph) -> LibName -> DGraph
forall a b. (a -> b) -> a -> b
$ IntIState -> LibName
i_ln IntIState
ist
    allRefTree :: Gr RTNodeLab RTLinkLab
allRefTree = DGraph -> Gr RTNodeLab RTLinkLab
refTree DGraph
dg
    ccomp :: [Int]
ccomp = Set Int -> Gr RTNodeLab RTLinkLab -> [Int]
forall (gr :: * -> * -> *) a b.
Graph gr =>
Set Int -> gr a b -> [Int]
getConnectedComps ([Int] -> Set Int
forall a. Ord a => [a] -> Set a
Set.fromList [Int]
roots) Gr RTNodeLab RTLinkLab
allRefTree
    getConnectedComps :: Set Int -> gr a b -> [Int]
getConnectedComps nodes0 :: Set Int
nodes0 tree :: gr a b
tree = 
     let nodes1 :: [Int]
nodes1 = (Int -> [Int]) -> [Int] -> [Int]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (gr a b -> Int -> [Int]
forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> Int -> [Int]
suc gr a b
tree) ([Int] -> [Int]) -> [Int] -> [Int]
forall a b. (a -> b) -> a -> b
$ Set Int -> [Int]
forall a. Set a -> [a]
Set.toList Set Int
nodes0
     in if Set Int -> Set Int -> Bool
forall a. Ord a => Set a -> Set a -> Bool
Set.isSubsetOf ([Int] -> Set Int
forall a. Ord a => [a] -> Set a
Set.fromList [Int]
nodes1) (Set Int -> Bool) -> Set Int -> Bool
forall a b. (a -> b) -> a -> b
$ Set Int
nodes0 
           then Set Int -> [Int]
forall a. Set a -> [a]
Set.toList Set Int
nodes0 
           else Set Int -> gr a b -> [Int]
getConnectedComps 
                  ((Set Int -> Int -> Set Int) -> Set Int -> [Int] -> Set Int
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\ s :: Set Int
s x :: Int
x -> Int -> Set Int -> Set Int
forall a. Ord a => a -> Set a -> Set a
Set.insert Int
x Set Int
s) Set Int
nodes0 [Int]
nodes1) gr a b
tree
    rTree :: Gr RTNodeLab RTLinkLab
rTree = [Int] -> Gr RTNodeLab RTLinkLab -> Gr RTNodeLab RTLinkLab
forall (gr :: * -> * -> *) a b.
DynGraph gr =>
[Int] -> gr a b -> gr a b
Tree.subgraph [Int]
ccomp Gr RTNodeLab RTLinkLab
allRefTree
    vertexes :: [Int]
vertexes = ((Int, RTNodeLab) -> Int) -> [(Int, RTNodeLab)] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (Int, RTNodeLab) -> Int
forall a b. (a, b) -> a
fst ([(Int, RTNodeLab)] -> [Int]) -> [(Int, RTNodeLab)] -> [Int]
forall a b. (a -> b) -> a -> b
$ Gr RTNodeLab RTLinkLab -> [(Int, RTNodeLab)]
forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> [LNode a]
Tree.labNodes Gr RTNodeLab RTLinkLab
rTree
    isRoot :: Int -> Bool
isRoot n :: Int
n = (((Int, Int, RTLinkLab) -> Bool) -> [(Int, Int, RTLinkLab)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\ (_, _, llab :: RTLinkLab
llab) -> RTLinkLab -> RTLinkType
rtl_type RTLinkLab
llab RTLinkType -> RTLinkType -> Bool
forall a. Eq a => a -> a -> Bool
== RTLinkType
RTComp) ([(Int, Int, RTLinkLab)] -> Bool)
-> [(Int, Int, RTLinkLab)] -> Bool
forall a b. (a -> b) -> a -> b
$
                Gr RTNodeLab RTLinkLab -> Int -> [(Int, Int, RTLinkLab)]
forall (gr :: * -> * -> *) a b.
Graph gr =>
gr a b -> Int -> [LEdge b]
out Gr RTNodeLab RTLinkLab
rTree Int
n) Bool -> Bool -> Bool
&& Bool -> Bool
not
               (((Int, Int, RTLinkLab) -> Bool) -> [(Int, Int, RTLinkLab)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\ (_, _, llab :: RTLinkLab
llab) -> RTLinkLab -> RTLinkType
rtl_type RTLinkLab
llab RTLinkType -> RTLinkType -> Bool
forall a. Eq a => a -> a -> Bool
== RTLinkType
RTComp) ([(Int, Int, RTLinkLab)] -> Bool)
-> [(Int, Int, RTLinkLab)] -> Bool
forall a b. (a -> b) -> a -> b
$
                Gr RTNodeLab RTLinkLab -> Int -> [(Int, Int, RTLinkLab)]
forall (gr :: * -> * -> *) a b.
Graph gr =>
gr a b -> Int -> [LEdge b]
inn Gr RTNodeLab RTLinkLab
rTree Int
n)
        -- look for outgoing component links
    arcs :: [(Int, Int, RTLinkLab)]
arcs = Gr RTNodeLab RTLinkLab -> [(Int, Int, RTLinkLab)]
forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> [LEdge b]
Tree.labEdges Gr RTNodeLab RTLinkLab
rTree
    subNodeMenuRoots :: LocalMenu Int
subNodeMenuRoots = MenuPrim (Maybe [Char]) (Int -> IO ()) -> LocalMenu Int
forall value.
MenuPrim (Maybe [Char]) (value -> IO ()) -> LocalMenu value
LocalMenu (Maybe [Char]
-> [MenuPrim (Maybe [Char]) (Int -> IO ())]
-> MenuPrim (Maybe [Char]) (Int -> IO ())
forall subMenuValue value.
subMenuValue
-> [MenuPrim subMenuValue value] -> MenuPrim subMenuValue value
UDG.Menu Maybe [Char]
forall a. Maybe a
Nothing [
                   [Char] -> (Int -> IO ()) -> MenuPrim (Maybe [Char]) (Int -> IO ())
forall subMenuValue value.
[Char] -> value -> MenuPrim subMenuValue value
Button "Show dependency diagram" ((Int -> IO ()) -> MenuPrim (Maybe [Char]) (Int -> IO ()))
-> (Int -> IO ()) -> MenuPrim (Maybe [Char]) (Int -> IO ())
forall a b. (a -> b) -> a -> b
$ GInfo -> DGraph -> Int -> IO ()
showDiagram GInfo
gInfo DGraph
dg,
                   [Char] -> (Int -> IO ()) -> MenuPrim (Maybe [Char]) (Int -> IO ())
forall subMenuValue value.
[Char] -> value -> MenuPrim subMenuValue value
Button "Show spec" ((Int -> IO ()) -> MenuPrim (Maybe [Char]) (Int -> IO ()))
-> (Int -> IO ()) -> MenuPrim (Maybe [Char]) (Int -> IO ())
forall a b. (a -> b) -> a -> b
$ DGraph -> Int -> IO ()
showSpec DGraph
dg,
                   [Char] -> (Int -> IO ()) -> MenuPrim (Maybe [Char]) (Int -> IO ())
forall subMenuValue value.
[Char] -> value -> MenuPrim subMenuValue value
Button "Check consistency" ((Int -> IO ()) -> MenuPrim (Maybe [Char]) (Int -> IO ()))
-> (Int -> IO ()) -> MenuPrim (Maybe [Char]) (Int -> IO ())
forall a b. (a -> b) -> a -> b
$ GInfo -> Int -> IO ()
checkCons GInfo
gInfo])
    subNodeMenu :: LocalMenu Int
subNodeMenu = MenuPrim (Maybe [Char]) (Int -> IO ()) -> LocalMenu Int
forall value.
MenuPrim (Maybe [Char]) (value -> IO ()) -> LocalMenu value
LocalMenu (Maybe [Char]
-> [MenuPrim (Maybe [Char]) (Int -> IO ())]
-> MenuPrim (Maybe [Char]) (Int -> IO ())
forall subMenuValue value.
subMenuValue
-> [MenuPrim subMenuValue value] -> MenuPrim subMenuValue value
UDG.Menu Maybe [Char]
forall a. Maybe a
Nothing [
                   [Char] -> (Int -> IO ()) -> MenuPrim (Maybe [Char]) (Int -> IO ())
forall subMenuValue value.
[Char] -> value -> MenuPrim subMenuValue value
Button "Show spec" ((Int -> IO ()) -> MenuPrim (Maybe [Char]) (Int -> IO ()))
-> (Int -> IO ()) -> MenuPrim (Maybe [Char]) (Int -> IO ())
forall a b. (a -> b) -> a -> b
$ DGraph -> Int -> IO ()
showSpec DGraph
dg,
                   [Char] -> (Int -> IO ()) -> MenuPrim (Maybe [Char]) (Int -> IO ())
forall subMenuValue value.
[Char] -> value -> MenuPrim subMenuValue value
Button "Check consistency" ((Int -> IO ()) -> MenuPrim (Maybe [Char]) (Int -> IO ()))
-> (Int -> IO ()) -> MenuPrim (Maybe [Char]) (Int -> IO ())
forall a b. (a -> b) -> a -> b
$ GInfo -> Int -> IO ()
checkCons GInfo
gInfo])
    subNodeTypeParmsR :: DaVinciNodeTypeParms Int
subNodeTypeParmsR = LocalMenu Int
subNodeMenuRoots LocalMenu Int
-> DaVinciNodeTypeParms Int -> DaVinciNodeTypeParms Int
forall (option :: * -> *) (configuration :: * -> *) value.
(HasConfigValue option configuration, Typeable value) =>
option value -> configuration value -> configuration value
$$$
                        Shape Int
forall value. Shape value
Ellipse Shape Int -> DaVinciNodeTypeParms Int -> DaVinciNodeTypeParms Int
forall (option :: * -> *) (configuration :: * -> *) value.
(HasConfigValue option configuration, Typeable value) =>
option value -> configuration value -> configuration value
$$$
                        (Int -> IO [Char]) -> ValueTitle Int
forall value. (value -> IO [Char]) -> ValueTitle value
ValueTitle ([Char] -> IO [Char]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Char] -> IO [Char]) -> (Int -> [Char]) -> Int -> IO [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RTNodeLab -> [Char]
rtn_name (RTNodeLab -> [Char]) -> (Int -> RTNodeLab) -> Int -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DGraph -> Int -> RTNodeLab
labRT DGraph
dg) ValueTitle Int
-> DaVinciNodeTypeParms Int -> DaVinciNodeTypeParms Int
forall (option :: * -> *) (configuration :: * -> *) value.
(HasConfigValue option configuration, Typeable value) =>
option value -> configuration value -> configuration value
$$$
                        [Char] -> Color Int
forall value. [Char] -> Color value
Color (HetcatsOpts -> Colors -> Bool -> Bool -> [Char]
getColor HetcatsOpts
opts Colors
Blue Bool
True Bool
True) Color Int -> DaVinciNodeTypeParms Int -> DaVinciNodeTypeParms Int
forall (option :: * -> *) (configuration :: * -> *) value.
(HasConfigValue option configuration, Typeable value) =>
option value -> configuration value -> configuration value
$$$
                        DaVinciNodeTypeParms Int
forall (nodeTypeParms :: * -> *) value.
(NodeTypeParms nodeTypeParms, Typeable value) =>
nodeTypeParms value
emptyNodeTypeParms
    subNodeTypeParms :: DaVinciNodeTypeParms Int
subNodeTypeParms = LocalMenu Int
subNodeMenu LocalMenu Int
-> DaVinciNodeTypeParms Int -> DaVinciNodeTypeParms Int
forall (option :: * -> *) (configuration :: * -> *) value.
(HasConfigValue option configuration, Typeable value) =>
option value -> configuration value -> configuration value
$$$
                       Shape Int
forall value. Shape value
Ellipse Shape Int -> DaVinciNodeTypeParms Int -> DaVinciNodeTypeParms Int
forall (option :: * -> *) (configuration :: * -> *) value.
(HasConfigValue option configuration, Typeable value) =>
option value -> configuration value -> configuration value
$$$
                       (Int -> IO [Char]) -> ValueTitle Int
forall value. (value -> IO [Char]) -> ValueTitle value
ValueTitle ([Char] -> IO [Char]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Char] -> IO [Char]) -> (Int -> [Char]) -> Int -> IO [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RTNodeLab -> [Char]
rtn_name (RTNodeLab -> [Char]) -> (Int -> RTNodeLab) -> Int -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DGraph -> Int -> RTNodeLab
labRT DGraph
dg) ValueTitle Int
-> DaVinciNodeTypeParms Int -> DaVinciNodeTypeParms Int
forall (option :: * -> *) (configuration :: * -> *) value.
(HasConfigValue option configuration, Typeable value) =>
option value -> configuration value -> configuration value
$$$
                       [Char] -> Color Int
forall value. [Char] -> Color value
Color (HetcatsOpts -> Colors -> Bool -> Bool -> [Char]
getColor HetcatsOpts
opts Colors
Green Bool
True Bool
True) Color Int -> DaVinciNodeTypeParms Int -> DaVinciNodeTypeParms Int
forall (option :: * -> *) (configuration :: * -> *) value.
(HasConfigValue option configuration, Typeable value) =>
option value -> configuration value -> configuration value
$$$
                       DaVinciNodeTypeParms Int
forall (nodeTypeParms :: * -> *) value.
(NodeTypeParms nodeTypeParms, Typeable value) =>
nodeTypeParms value
emptyNodeTypeParms
   DaVinciNodeType Int
subNodeType <- Graph
  DaVinciGraph
  DaVinciGraphParms
  DaVinciNode
  DaVinciNodeType
  DaVinciNodeTypeParms
  DaVinciArc
  DaVinciArcType
  DaVinciArcTypeParms
-> DaVinciNodeTypeParms Int -> IO (DaVinciNodeType Int)
forall graph graphParms (node :: * -> *) (nodeType :: * -> *)
       (nodeTypeParms :: * -> *) (arc :: * -> *) (arcType :: * -> *)
       (arcTypeParms :: * -> *) value.
(GraphAll
   graph
   graphParms
   node
   nodeType
   nodeTypeParms
   arc
   arcType
   arcTypeParms,
 Typeable value) =>
Graph
  graph
  graphParms
  node
  nodeType
  nodeTypeParms
  arc
  arcType
  arcTypeParms
-> nodeTypeParms value -> IO (nodeType value)
newNodeType Graph
  DaVinciGraph
  DaVinciGraphParms
  DaVinciNode
  DaVinciNodeType
  DaVinciNodeTypeParms
  DaVinciArc
  DaVinciArcType
  DaVinciArcTypeParms
graph DaVinciNodeTypeParms Int
subNodeTypeParms
   -- subNodeListI <- mapM (newNode graph subNodeType) internal
   DaVinciNodeType Int
subNodeTypeR <- Graph
  DaVinciGraph
  DaVinciGraphParms
  DaVinciNode
  DaVinciNodeType
  DaVinciNodeTypeParms
  DaVinciArc
  DaVinciArcType
  DaVinciArcTypeParms
-> DaVinciNodeTypeParms Int -> IO (DaVinciNodeType Int)
forall graph graphParms (node :: * -> *) (nodeType :: * -> *)
       (nodeTypeParms :: * -> *) (arc :: * -> *) (arcType :: * -> *)
       (arcTypeParms :: * -> *) value.
(GraphAll
   graph
   graphParms
   node
   nodeType
   nodeTypeParms
   arc
   arcType
   arcTypeParms,
 Typeable value) =>
Graph
  graph
  graphParms
  node
  nodeType
  nodeTypeParms
  arc
  arcType
  arcTypeParms
-> nodeTypeParms value -> IO (nodeType value)
newNodeType Graph
  DaVinciGraph
  DaVinciGraphParms
  DaVinciNode
  DaVinciNodeType
  DaVinciNodeTypeParms
  DaVinciArc
  DaVinciArcType
  DaVinciArcTypeParms
graph DaVinciNodeTypeParms Int
subNodeTypeParmsR
   [DaVinciNode Int]
subNodeList <- (Int -> IO (DaVinciNode Int)) -> [Int] -> IO [DaVinciNode Int]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\ x :: Int
x -> if Int -> Bool
isRoot Int
x then
                                Graph
  DaVinciGraph
  DaVinciGraphParms
  DaVinciNode
  DaVinciNodeType
  DaVinciNodeTypeParms
  DaVinciArc
  DaVinciArcType
  DaVinciArcTypeParms
-> DaVinciNodeType Int -> Int -> IO (DaVinciNode Int)
forall graph graphParms (node :: * -> *) (nodeType :: * -> *)
       (nodeTypeParms :: * -> *) (arc :: * -> *) (arcType :: * -> *)
       (arcTypeParms :: * -> *) value.
(GraphAll
   graph
   graphParms
   node
   nodeType
   nodeTypeParms
   arc
   arcType
   arcTypeParms,
 Typeable value) =>
Graph
  graph
  graphParms
  node
  nodeType
  nodeTypeParms
  arc
  arcType
  arcTypeParms
-> nodeType value -> value -> IO (node value)
newNode Graph
  DaVinciGraph
  DaVinciGraphParms
  DaVinciNode
  DaVinciNodeType
  DaVinciNodeTypeParms
  DaVinciArc
  DaVinciArcType
  DaVinciArcTypeParms
graph DaVinciNodeType Int
subNodeTypeR Int
x
                              else Graph
  DaVinciGraph
  DaVinciGraphParms
  DaVinciNode
  DaVinciNodeType
  DaVinciNodeTypeParms
  DaVinciArc
  DaVinciArcType
  DaVinciArcTypeParms
-> DaVinciNodeType Int -> Int -> IO (DaVinciNode Int)
forall graph graphParms (node :: * -> *) (nodeType :: * -> *)
       (nodeTypeParms :: * -> *) (arc :: * -> *) (arcType :: * -> *)
       (arcTypeParms :: * -> *) value.
(GraphAll
   graph
   graphParms
   node
   nodeType
   nodeTypeParms
   arc
   arcType
   arcTypeParms,
 Typeable value) =>
Graph
  graph
  graphParms
  node
  nodeType
  nodeTypeParms
  arc
  arcType
  arcTypeParms
-> nodeType value -> value -> IO (node value)
newNode Graph
  DaVinciGraph
  DaVinciGraphParms
  DaVinciNode
  DaVinciNodeType
  DaVinciNodeTypeParms
  DaVinciArc
  DaVinciArcType
  DaVinciArcTypeParms
graph DaVinciNodeType Int
subNodeType Int
x) [Int]
vertexes
   -- let subNodeList = subNodeListI ++ subNodeListR
   let
    nodes' :: Map Int (DaVinciNode Int)
nodes' = [(Int, DaVinciNode Int)] -> Map Int (DaVinciNode Int)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(Int, DaVinciNode Int)] -> Map Int (DaVinciNode Int))
-> [(Int, DaVinciNode Int)] -> Map Int (DaVinciNode Int)
forall a b. (a -> b) -> a -> b
$ [Int] -> [DaVinciNode Int] -> [(Int, DaVinciNode Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip (Gr RTNodeLab RTLinkLab -> [Int]
forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> [Int]
Tree.nodes Gr RTNodeLab RTLinkLab
rTree) [DaVinciNode Int]
subNodeList
    subArcMenu :: LocalMenu value
subArcMenu = MenuPrim (Maybe [Char]) (value -> IO ()) -> LocalMenu value
forall value.
MenuPrim (Maybe [Char]) (value -> IO ()) -> LocalMenu value
LocalMenu (Maybe [Char]
-> [MenuPrim (Maybe [Char]) (value -> IO ())]
-> MenuPrim (Maybe [Char]) (value -> IO ())
forall subMenuValue value.
subMenuValue
-> [MenuPrim subMenuValue value] -> MenuPrim subMenuValue value
UDG.Menu Maybe [Char]
forall a. Maybe a
Nothing [])
    subArcTypeParms :: DaVinciArcTypeParms (IO RTLinkLab)
subArcTypeParms = LocalMenu (IO RTLinkLab)
forall value. LocalMenu value
subArcMenu LocalMenu (IO RTLinkLab)
-> DaVinciArcTypeParms (IO RTLinkLab)
-> DaVinciArcTypeParms (IO RTLinkLab)
forall (option :: * -> *) (configuration :: * -> *) value.
(HasConfigValue option configuration, Typeable value) =>
option value -> configuration value -> configuration value
$$$
                      (IO RTLinkLab -> IO [Char]) -> ValueTitle (IO RTLinkLab)
forall value. (value -> IO [Char]) -> ValueTitle value
ValueTitle (IO [Char] -> IO RTLinkLab -> IO [Char]
forall (m :: * -> *) a. Monad m => a -> m a
return (IO [Char] -> IO RTLinkLab -> IO [Char])
-> IO [Char] -> IO RTLinkLab -> IO [Char]
forall a b. (a -> b) -> a -> b
$ [Char] -> IO [Char]
forall (m :: * -> *) a. Monad m => a -> m a
return "") ValueTitle (IO RTLinkLab)
-> DaVinciArcTypeParms (IO RTLinkLab)
-> DaVinciArcTypeParms (IO RTLinkLab)
forall (option :: * -> *) (configuration :: * -> *) value.
(HasConfigValue option configuration, Typeable value) =>
option value -> configuration value -> configuration value
$$$
                      [Char] -> Color (IO RTLinkLab)
forall value. [Char] -> Color value
Color (HetcatsOpts -> Colors -> Bool -> Bool -> [Char]
getColor HetcatsOpts
opts Colors
Black Bool
False Bool
False) Color (IO RTLinkLab)
-> DaVinciArcTypeParms (IO RTLinkLab)
-> DaVinciArcTypeParms (IO RTLinkLab)
forall (option :: * -> *) (configuration :: * -> *) value.
(HasConfigValue option configuration, Typeable value) =>
option value -> configuration value -> configuration value
$$$
                      DaVinciArcTypeParms (IO RTLinkLab)
forall (arcTypeParms :: * -> *) value.
(ArcTypeParms arcTypeParms, Typeable value) =>
arcTypeParms value
emptyArcTypeParms
    subArcTypeParmsT :: DaVinciArcTypeParms (IO RTLinkLab)
subArcTypeParmsT = LocalMenu (IO RTLinkLab)
forall value. LocalMenu value
subArcMenu LocalMenu (IO RTLinkLab)
-> DaVinciArcTypeParms (IO RTLinkLab)
-> DaVinciArcTypeParms (IO RTLinkLab)
forall (option :: * -> *) (configuration :: * -> *) value.
(HasConfigValue option configuration, Typeable value) =>
option value -> configuration value -> configuration value
$$$
                      (IO RTLinkLab -> IO [Char]) -> ValueTitle (IO RTLinkLab)
forall value. (value -> IO [Char]) -> ValueTitle value
ValueTitle (IO [Char] -> IO RTLinkLab -> IO [Char]
forall (m :: * -> *) a. Monad m => a -> m a
return (IO [Char] -> IO RTLinkLab -> IO [Char])
-> IO [Char] -> IO RTLinkLab -> IO [Char]
forall a b. (a -> b) -> a -> b
$ [Char] -> IO [Char]
forall (m :: * -> *) a. Monad m => a -> m a
return "") ValueTitle (IO RTLinkLab)
-> DaVinciArcTypeParms (IO RTLinkLab)
-> DaVinciArcTypeParms (IO RTLinkLab)
forall (option :: * -> *) (configuration :: * -> *) value.
(HasConfigValue option configuration, Typeable value) =>
option value -> configuration value -> configuration value
$$$
                      [Char] -> Color (IO RTLinkLab)
forall value. [Char] -> Color value
Color (HetcatsOpts -> Colors -> Bool -> Bool -> [Char]
getColor HetcatsOpts
opts Colors
Blue Bool
False Bool
False) Color (IO RTLinkLab)
-> DaVinciArcTypeParms (IO RTLinkLab)
-> DaVinciArcTypeParms (IO RTLinkLab)
forall (option :: * -> *) (configuration :: * -> *) value.
(HasConfigValue option configuration, Typeable value) =>
option value -> configuration value -> configuration value
$$$
                      DaVinciArcTypeParms (IO RTLinkLab)
forall (arcTypeParms :: * -> *) value.
(ArcTypeParms arcTypeParms, Typeable value) =>
arcTypeParms value
emptyArcTypeParms
    subArcTypeParmsR :: DaVinciArcTypeParms (IO RTLinkLab)
subArcTypeParmsR = LocalMenu (IO RTLinkLab)
forall value. LocalMenu value
subArcMenu LocalMenu (IO RTLinkLab)
-> DaVinciArcTypeParms (IO RTLinkLab)
-> DaVinciArcTypeParms (IO RTLinkLab)
forall (option :: * -> *) (configuration :: * -> *) value.
(HasConfigValue option configuration, Typeable value) =>
option value -> configuration value -> configuration value
$$$
                      (IO RTLinkLab -> IO [Char]) -> ValueTitle (IO RTLinkLab)
forall value. (value -> IO [Char]) -> ValueTitle value
ValueTitle (IO [Char] -> IO RTLinkLab -> IO [Char]
forall (m :: * -> *) a. Monad m => a -> m a
return (IO [Char] -> IO RTLinkLab -> IO [Char])
-> IO [Char] -> IO RTLinkLab -> IO [Char]
forall a b. (a -> b) -> a -> b
$ [Char] -> IO [Char]
forall (m :: * -> *) a. Monad m => a -> m a
return "") ValueTitle (IO RTLinkLab)
-> DaVinciArcTypeParms (IO RTLinkLab)
-> DaVinciArcTypeParms (IO RTLinkLab)
forall (option :: * -> *) (configuration :: * -> *) value.
(HasConfigValue option configuration, Typeable value) =>
option value -> configuration value -> configuration value
$$$
                      [Char] -> Color (IO RTLinkLab)
forall value. [Char] -> Color value
Color (HetcatsOpts -> Colors -> Bool -> Bool -> [Char]
getColor HetcatsOpts
opts Colors
Coral Bool
False Bool
False) Color (IO RTLinkLab)
-> DaVinciArcTypeParms (IO RTLinkLab)
-> DaVinciArcTypeParms (IO RTLinkLab)
forall (option :: * -> *) (configuration :: * -> *) value.
(HasConfigValue option configuration, Typeable value) =>
option value -> configuration value -> configuration value
$$$
                      DaVinciArcTypeParms (IO RTLinkLab)
forall (arcTypeParms :: * -> *) value.
(ArcTypeParms arcTypeParms, Typeable value) =>
arcTypeParms value
emptyArcTypeParms
   DaVinciArcType (IO RTLinkLab)
subArcType <- Graph
  DaVinciGraph
  DaVinciGraphParms
  DaVinciNode
  DaVinciNodeType
  DaVinciNodeTypeParms
  DaVinciArc
  DaVinciArcType
  DaVinciArcTypeParms
-> DaVinciArcTypeParms (IO RTLinkLab)
-> IO (DaVinciArcType (IO RTLinkLab))
forall graph graphParms (node :: * -> *) (nodeType :: * -> *)
       (nodeTypeParms :: * -> *) (arc :: * -> *) (arcType :: * -> *)
       (arcTypeParms :: * -> *) value.
(GraphAll
   graph
   graphParms
   node
   nodeType
   nodeTypeParms
   arc
   arcType
   arcTypeParms,
 Typeable value) =>
Graph
  graph
  graphParms
  node
  nodeType
  nodeTypeParms
  arc
  arcType
  arcTypeParms
-> arcTypeParms value -> IO (arcType value)
newArcType Graph
  DaVinciGraph
  DaVinciGraphParms
  DaVinciNode
  DaVinciNodeType
  DaVinciNodeTypeParms
  DaVinciArc
  DaVinciArcType
  DaVinciArcTypeParms
graph DaVinciArcTypeParms (IO RTLinkLab)
subArcTypeParms
   let insertSubArc :: (Int, Int, RTLinkLab) -> IO (DaVinciArc (IO RTLinkLab))
insertSubArc (n1 :: Int
n1, n2 :: Int
n2, e :: RTLinkLab
e) = Graph
  DaVinciGraph
  DaVinciGraphParms
  DaVinciNode
  DaVinciNodeType
  DaVinciNodeTypeParms
  DaVinciArc
  DaVinciArcType
  DaVinciArcTypeParms
-> DaVinciArcType (IO RTLinkLab)
-> IO RTLinkLab
-> DaVinciNode Int
-> DaVinciNode Int
-> IO (DaVinciArc (IO RTLinkLab))
forall graph graphParms (node :: * -> *) (nodeType :: * -> *)
       (nodeTypeParms :: * -> *) (arc :: * -> *) (arcType :: * -> *)
       (arcTypeParms :: * -> *) value nodeFromValue nodeToValue.
(GraphAll
   graph
   graphParms
   node
   nodeType
   nodeTypeParms
   arc
   arcType
   arcTypeParms,
 Typeable value, Typeable nodeFromValue, Typeable nodeToValue) =>
Graph
  graph
  graphParms
  node
  nodeType
  nodeTypeParms
  arc
  arcType
  arcTypeParms
-> arcType value
-> value
-> node nodeFromValue
-> node nodeToValue
-> IO (arc value)
newArc Graph
  DaVinciGraph
  DaVinciGraphParms
  DaVinciNode
  DaVinciNodeType
  DaVinciNodeTypeParms
  DaVinciArc
  DaVinciArcType
  DaVinciArcTypeParms
graph DaVinciArcType (IO RTLinkLab)
subArcType
                                            (RTLinkLab -> IO RTLinkLab
forall (m :: * -> *) a. Monad m => a -> m a
return RTLinkLab
e)
                                            (Map Int (DaVinciNode Int) -> Int -> DaVinciNode Int
forall a b. Ord a => Map a b -> a -> b
lookup' Map Int (DaVinciNode Int)
nodes' Int
n1)
                                            (Map Int (DaVinciNode Int) -> Int -> DaVinciNode Int
forall a b. Ord a => Map a b -> a -> b
lookup' Map Int (DaVinciNode Int)
nodes' Int
n2)
   [DaVinciArc (IO RTLinkLab)]
subArcList <- ((Int, Int, RTLinkLab) -> IO (DaVinciArc (IO RTLinkLab)))
-> [(Int, Int, RTLinkLab)] -> IO [DaVinciArc (IO RTLinkLab)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Int, Int, RTLinkLab) -> IO (DaVinciArc (IO RTLinkLab))
insertSubArc ([(Int, Int, RTLinkLab)] -> IO [DaVinciArc (IO RTLinkLab)])
-> [(Int, Int, RTLinkLab)] -> IO [DaVinciArc (IO RTLinkLab)]
forall a b. (a -> b) -> a -> b
$
                    ((Int, Int, RTLinkLab) -> Bool)
-> [(Int, Int, RTLinkLab)] -> [(Int, Int, RTLinkLab)]
forall a. (a -> Bool) -> [a] -> [a]
filter (\ (_, _, e :: RTLinkLab
e) -> RTLinkLab -> RTLinkType
rtl_type RTLinkLab
e RTLinkType -> RTLinkType -> Bool
forall a. Eq a => a -> a -> Bool
== RTLinkType
RTComp) [(Int, Int, RTLinkLab)]
arcs
   DaVinciArcType (IO RTLinkLab)
subArcTypeT <- Graph
  DaVinciGraph
  DaVinciGraphParms
  DaVinciNode
  DaVinciNodeType
  DaVinciNodeTypeParms
  DaVinciArc
  DaVinciArcType
  DaVinciArcTypeParms
-> DaVinciArcTypeParms (IO RTLinkLab)
-> IO (DaVinciArcType (IO RTLinkLab))
forall graph graphParms (node :: * -> *) (nodeType :: * -> *)
       (nodeTypeParms :: * -> *) (arc :: * -> *) (arcType :: * -> *)
       (arcTypeParms :: * -> *) value.
(GraphAll
   graph
   graphParms
   node
   nodeType
   nodeTypeParms
   arc
   arcType
   arcTypeParms,
 Typeable value) =>
Graph
  graph
  graphParms
  node
  nodeType
  nodeTypeParms
  arc
  arcType
  arcTypeParms
-> arcTypeParms value -> IO (arcType value)
newArcType Graph
  DaVinciGraph
  DaVinciGraphParms
  DaVinciNode
  DaVinciNodeType
  DaVinciNodeTypeParms
  DaVinciArc
  DaVinciArcType
  DaVinciArcTypeParms
graph DaVinciArcTypeParms (IO RTLinkLab)
subArcTypeParmsT
   let insertSubArcT :: (Int, Int, RTLinkLab) -> IO (DaVinciArc (IO RTLinkLab))
insertSubArcT (n1 :: Int
n1, n2 :: Int
n2, e :: RTLinkLab
e) = Graph
  DaVinciGraph
  DaVinciGraphParms
  DaVinciNode
  DaVinciNodeType
  DaVinciNodeTypeParms
  DaVinciArc
  DaVinciArcType
  DaVinciArcTypeParms
-> DaVinciArcType (IO RTLinkLab)
-> IO RTLinkLab
-> DaVinciNode Int
-> DaVinciNode Int
-> IO (DaVinciArc (IO RTLinkLab))
forall graph graphParms (node :: * -> *) (nodeType :: * -> *)
       (nodeTypeParms :: * -> *) (arc :: * -> *) (arcType :: * -> *)
       (arcTypeParms :: * -> *) value nodeFromValue nodeToValue.
(GraphAll
   graph
   graphParms
   node
   nodeType
   nodeTypeParms
   arc
   arcType
   arcTypeParms,
 Typeable value, Typeable nodeFromValue, Typeable nodeToValue) =>
Graph
  graph
  graphParms
  node
  nodeType
  nodeTypeParms
  arc
  arcType
  arcTypeParms
-> arcType value
-> value
-> node nodeFromValue
-> node nodeToValue
-> IO (arc value)
newArc Graph
  DaVinciGraph
  DaVinciGraphParms
  DaVinciNode
  DaVinciNodeType
  DaVinciNodeTypeParms
  DaVinciArc
  DaVinciArcType
  DaVinciArcTypeParms
graph DaVinciArcType (IO RTLinkLab)
subArcTypeT
                                             (RTLinkLab -> IO RTLinkLab
forall (m :: * -> *) a. Monad m => a -> m a
return RTLinkLab
e)
                                            (Map Int (DaVinciNode Int) -> Int -> DaVinciNode Int
forall a b. Ord a => Map a b -> a -> b
lookup' Map Int (DaVinciNode Int)
nodes' Int
n1)
                                            (Map Int (DaVinciNode Int) -> Int -> DaVinciNode Int
forall a b. Ord a => Map a b -> a -> b
lookup' Map Int (DaVinciNode Int)
nodes' Int
n2)
   [DaVinciArc (IO RTLinkLab)]
subArcListT <- ((Int, Int, RTLinkLab) -> IO (DaVinciArc (IO RTLinkLab)))
-> [(Int, Int, RTLinkLab)] -> IO [DaVinciArc (IO RTLinkLab)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Int, Int, RTLinkLab) -> IO (DaVinciArc (IO RTLinkLab))
insertSubArcT ([(Int, Int, RTLinkLab)] -> IO [DaVinciArc (IO RTLinkLab)])
-> [(Int, Int, RTLinkLab)] -> IO [DaVinciArc (IO RTLinkLab)]
forall a b. (a -> b) -> a -> b
$
                    ((Int, Int, RTLinkLab) -> Bool)
-> [(Int, Int, RTLinkLab)] -> [(Int, Int, RTLinkLab)]
forall a. (a -> Bool) -> [a] -> [a]
filter (\ (_, _, _e :: RTLinkLab
_e) -> Bool
False) -- TODO: it was easier
                    [(Int, Int, RTLinkLab)]
arcs
   DaVinciArcType (IO RTLinkLab)
subArcTypeR <- Graph
  DaVinciGraph
  DaVinciGraphParms
  DaVinciNode
  DaVinciNodeType
  DaVinciNodeTypeParms
  DaVinciArc
  DaVinciArcType
  DaVinciArcTypeParms
-> DaVinciArcTypeParms (IO RTLinkLab)
-> IO (DaVinciArcType (IO RTLinkLab))
forall graph graphParms (node :: * -> *) (nodeType :: * -> *)
       (nodeTypeParms :: * -> *) (arc :: * -> *) (arcType :: * -> *)
       (arcTypeParms :: * -> *) value.
(GraphAll
   graph
   graphParms
   node
   nodeType
   nodeTypeParms
   arc
   arcType
   arcTypeParms,
 Typeable value) =>
Graph
  graph
  graphParms
  node
  nodeType
  nodeTypeParms
  arc
  arcType
  arcTypeParms
-> arcTypeParms value -> IO (arcType value)
newArcType Graph
  DaVinciGraph
  DaVinciGraphParms
  DaVinciNode
  DaVinciNodeType
  DaVinciNodeTypeParms
  DaVinciArc
  DaVinciArcType
  DaVinciArcTypeParms
graph DaVinciArcTypeParms (IO RTLinkLab)
subArcTypeParmsR
   let insertSubArcR :: (Int, Int, RTLinkLab) -> IO (DaVinciArc (IO RTLinkLab))
insertSubArcR (n1 :: Int
n1, n2 :: Int
n2, e :: RTLinkLab
e) = Graph
  DaVinciGraph
  DaVinciGraphParms
  DaVinciNode
  DaVinciNodeType
  DaVinciNodeTypeParms
  DaVinciArc
  DaVinciArcType
  DaVinciArcTypeParms
-> DaVinciArcType (IO RTLinkLab)
-> IO RTLinkLab
-> DaVinciNode Int
-> DaVinciNode Int
-> IO (DaVinciArc (IO RTLinkLab))
forall graph graphParms (node :: * -> *) (nodeType :: * -> *)
       (nodeTypeParms :: * -> *) (arc :: * -> *) (arcType :: * -> *)
       (arcTypeParms :: * -> *) value nodeFromValue nodeToValue.
(GraphAll
   graph
   graphParms
   node
   nodeType
   nodeTypeParms
   arc
   arcType
   arcTypeParms,
 Typeable value, Typeable nodeFromValue, Typeable nodeToValue) =>
Graph
  graph
  graphParms
  node
  nodeType
  nodeTypeParms
  arc
  arcType
  arcTypeParms
-> arcType value
-> value
-> node nodeFromValue
-> node nodeToValue
-> IO (arc value)
newArc Graph
  DaVinciGraph
  DaVinciGraphParms
  DaVinciNode
  DaVinciNodeType
  DaVinciNodeTypeParms
  DaVinciArc
  DaVinciArcType
  DaVinciArcTypeParms
graph DaVinciArcType (IO RTLinkLab)
subArcTypeR
                                            (RTLinkLab -> IO RTLinkLab
forall (m :: * -> *) a. Monad m => a -> m a
return RTLinkLab
e)
                                            (Map Int (DaVinciNode Int) -> Int -> DaVinciNode Int
forall a b. Ord a => Map a b -> a -> b
lookup' Map Int (DaVinciNode Int)
nodes' Int
n1)
                                            (Map Int (DaVinciNode Int) -> Int -> DaVinciNode Int
forall a b. Ord a => Map a b -> a -> b
lookup' Map Int (DaVinciNode Int)
nodes' Int
n2)
   [DaVinciArc (IO RTLinkLab)]
subArcListR <- ((Int, Int, RTLinkLab) -> IO (DaVinciArc (IO RTLinkLab)))
-> [(Int, Int, RTLinkLab)] -> IO [DaVinciArc (IO RTLinkLab)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Int, Int, RTLinkLab) -> IO (DaVinciArc (IO RTLinkLab))
insertSubArcR ([(Int, Int, RTLinkLab)] -> IO [DaVinciArc (IO RTLinkLab)])
-> [(Int, Int, RTLinkLab)] -> IO [DaVinciArc (IO RTLinkLab)]
forall a b. (a -> b) -> a -> b
$
                    ((Int, Int, RTLinkLab) -> Bool)
-> [(Int, Int, RTLinkLab)] -> [(Int, Int, RTLinkLab)]
forall a. (a -> Bool) -> [a] -> [a]
filter (\ (_, _, e :: RTLinkLab
e) -> RTLinkLab -> RTLinkType
rtl_type RTLinkLab
e RTLinkType -> RTLinkType -> Bool
forall a. Eq a => a -> a -> Bool
== RTLinkType
RTRefine) [(Int, Int, RTLinkLab)]
arcs
   IORef NodeEdgeListRef -> NodeEdgeListRef -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef NodeEdgeListRef
nodesEdges ([DaVinciNode Int]
subNodeList, [DaVinciArc (IO RTLinkLab)]
subArcList [DaVinciArc (IO RTLinkLab)]
-> [DaVinciArc (IO RTLinkLab)] -> [DaVinciArc (IO RTLinkLab)]
forall a. [a] -> [a] -> [a]
++ [DaVinciArc (IO RTLinkLab)]
subArcListT
                                       [DaVinciArc (IO RTLinkLab)]
-> [DaVinciArc (IO RTLinkLab)] -> [DaVinciArc (IO RTLinkLab)]
forall a. [a] -> [a] -> [a]
++ [DaVinciArc (IO RTLinkLab)]
subArcListR)


checkCons :: GInfo -> Int -> IO ()
checkCons :: GInfo -> Int -> IO ()
checkCons gInfo :: GInfo
gInfo n :: Int
n = do
  LibFunc
lockGlobal GInfo
gInfo
  GInfo -> [Int] -> IO ()
checkConsAux GInfo
gInfo [Int
n]

checkConsAux :: GInfo -> [Int] -> IO ()
checkConsAux :: GInfo -> [Int] -> IO ()
checkConsAux gInfo :: GInfo
gInfo [] = LibFunc
unlockGlobal GInfo
gInfo
checkConsAux gInfo :: GInfo
gInfo (n :: Int
n : ns :: [Int]
ns) = do
 IntState
ost <- IORef IntState -> IO IntState
forall a. IORef a -> IO a
readIORef (IORef IntState -> IO IntState) -> IORef IntState -> IO IntState
forall a b. (a -> b) -> a -> b
$ GInfo -> IORef IntState
intState GInfo
gInfo
 case IntState -> Maybe IntIState
i_state IntState
ost of
  Nothing -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  Just ist :: IntIState
ist -> do
   let
    le :: LibEnv
le = IntIState -> LibEnv
i_libEnv IntIState
ist
    dg :: DGraph
dg = LibEnv -> LibName -> DGraph
forall a b. Ord a => Map a b -> a -> b
lookup' LibEnv
le (LibName -> DGraph) -> LibName -> DGraph
forall a b. (a -> b) -> a -> b
$ IntIState -> LibName
i_ln IntIState
ist
    rtlab :: RTNodeLab
rtlab = DGraph -> Int -> RTNodeLab
labRT DGraph
dg Int
n
    rt :: Gr RTNodeLab RTLinkLab
rt = DGraph -> Gr RTNodeLab RTLinkLab
refTree DGraph
dg
    changeConsStatus :: Int -> [DGChange]
changeConsStatus x :: Int
x = let
        oldLab :: DGNodeLab
oldLab = DGraph -> Int -> DGNodeLab
labDG DGraph
dg Int
x
        oldNInfo :: DGNodeInfo
oldNInfo = DGNodeLab -> DGNodeInfo
nodeInfo DGNodeLab
oldLab
        newLab :: DGNodeLab
newLab = DGNodeLab
oldLab {nodeInfo :: DGNodeInfo
nodeInfo = case DGNodeInfo
oldNInfo of
                                     DGNode o :: DGOrigin
o _ -> DGOrigin -> ConsStatus -> DGNodeInfo
DGNode DGOrigin
o (ConsStatus -> DGNodeInfo) -> ConsStatus -> DGNodeInfo
forall a b. (a -> b) -> a -> b
$ Conservativity -> ConsStatus
mkConsStatus Conservativity
Cons
                                     _ -> DGNodeInfo
oldNInfo}
       in [DGNodeLab -> LNode DGNodeLab -> DGChange
SetNodeLab DGNodeLab
oldLab (Int
x, DGNodeLab
newLab)]
    consLinks :: (Int, Int, DGLinkLab) -> [DGChange]
consLinks (s :: Int
s, t :: Int
t, l :: DGLinkLab
l) = let
        l' :: DGLinkLab
l' = DGLinkLab
l {dgl_type :: DGLinkType
dgl_type = case DGLinkLab -> DGLinkType
dgl_type DGLinkLab
l of
                           ScopedLink a :: Scope
a b :: LinkKind
b _ ->
                              Scope -> LinkKind -> ConsStatus -> DGLinkType
ScopedLink Scope
a LinkKind
b (ConsStatus -> DGLinkType) -> ConsStatus -> DGLinkType
forall a b. (a -> b) -> a -> b
$ Conservativity -> ConsStatus
mkConsStatus Conservativity
Cons
                           dt :: DGLinkType
dt -> DGLinkType
dt}
       in [(Int, Int, DGLinkLab) -> DGChange
DeleteEdge (Int
s, Int
t, DGLinkLab
l), (Int, Int, DGLinkLab) -> DGChange
InsertEdge (Int
s, Int
t, DGLinkLab
l')]
    updateDG :: [DGChange] -> IO ()
updateDG changes :: [DGChange]
changes = do
     let dg' :: DGraph
dg' = DGraph -> [DGChange] -> DGraph
changesDGH DGraph
dg [DGChange]
changes
         history :: ProofHistory
history = (ProofHistory, ProofHistory) -> ProofHistory
forall a b. (a, b) -> b
snd ((ProofHistory, ProofHistory) -> ProofHistory)
-> (ProofHistory, ProofHistory) -> ProofHistory
forall a b. (a -> b) -> a -> b
$ DGraph -> DGraph -> (ProofHistory, ProofHistory)
splitHistory DGraph
dg DGraph
dg'
         le' :: LibEnv
le' = LibName -> DGraph -> LibEnv -> LibEnv
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (IntIState -> LibName
i_ln IntIState
ist) DGraph
dg' LibEnv
le
         lln :: [UndoRedoElem]
lln = (LibName -> UndoRedoElem) -> [LibName] -> [UndoRedoElem]
forall a b. (a -> b) -> [a] -> [b]
map LibName -> UndoRedoElem
DgCommandChange ([LibName] -> [UndoRedoElem]) -> [LibName] -> [UndoRedoElem]
forall a b. (a -> b) -> a -> b
$ LibEnv -> LibEnv -> [LibName]
calcGlobalHistory LibEnv
le LibEnv
le'
         nst :: IntState
nst = Command -> IntState -> [UndoRedoElem] -> IntState
add2history Command
HelpCmd IntState
ost [UndoRedoElem]
lln
         nwst :: IntState
nwst = IntState
nst { i_state :: Maybe IntIState
i_state = IntIState -> Maybe IntIState
forall a. a -> Maybe a
Just IntIState
ist { i_libEnv :: LibEnv
i_libEnv = LibEnv
le'}}
     HetcatsOpts -> [Char] -> IO () -> IO ()
doDump (GInfo -> HetcatsOpts
hetcatsOpts GInfo
gInfo) "PrintHistory" (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
             [Char] -> IO ()
putStrLn "History"
             Doc -> IO ()
forall a. Show a => a -> IO ()
print (Doc -> IO ()) -> Doc -> IO ()
forall a b. (a -> b) -> a -> b
$ ProofHistory -> Doc
prettyHistory ProofHistory
history
     IORef IntState -> IntState -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (GInfo -> IORef IntState
intState GInfo
gInfo) IntState
nwst
     GInfo -> [DGChange] -> IO ()
updateGraph GInfo
gInfo ([DGChange] -> [DGChange]
forall a. [a] -> [a]
reverse ([DGChange] -> [DGChange]) -> [DGChange] -> [DGChange]
forall a b. (a -> b) -> a -> b
$ ProofHistory -> [DGChange]
flatHistory ProofHistory
history)
   case RTNodeLab -> RTNodeType
rtn_type RTNodeLab
rtlab of
     RTRef n' :: Int
n' -> GInfo -> [Int] -> IO ()
checkConsAux GInfo
gInfo ([Int] -> IO ()) -> [Int] -> IO ()
forall a b. (a -> b) -> a -> b
$ Int
n' Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: [Int]
ns
     RTPlain usig :: UnitSig
usig ->
      let units :: [Int]
units = ((Int, Int, RTLinkLab) -> Int) -> [(Int, Int, RTLinkLab)] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (\ (_, x :: Int
x, _) -> Int
x) ([(Int, Int, RTLinkLab)] -> [Int])
-> [(Int, Int, RTLinkLab)] -> [Int]
forall a b. (a -> b) -> a -> b
$
                 ((Int, Int, RTLinkLab) -> Bool)
-> [(Int, Int, RTLinkLab)] -> [(Int, Int, RTLinkLab)]
forall a. (a -> Bool) -> [a] -> [a]
filter (\ (_ss :: Int
_ss, _tt :: Int
_tt, ll :: RTLinkLab
ll) -> RTLinkLab -> RTLinkType
rtl_type RTLinkLab
ll RTLinkType -> RTLinkType -> Bool
forall a. Eq a => a -> a -> Bool
== RTLinkType
RTComp) ([(Int, Int, RTLinkLab)] -> [(Int, Int, RTLinkLab)])
-> [(Int, Int, RTLinkLab)] -> [(Int, Int, RTLinkLab)]
forall a b. (a -> b) -> a -> b
$ Gr RTNodeLab RTLinkLab -> Int -> [(Int, Int, RTLinkLab)]
forall (gr :: * -> * -> *) a b.
Graph gr =>
gr a b -> Int -> [LEdge b]
out Gr RTNodeLab RTLinkLab
rt Int
n
      in case [Int]
units of
          [] -> -- n is itself a unit, insert obligation
             case UnitSig
usig of
              UnitSig [] nsig :: NodeSig
nsig _ -> do -- non-parametric unit, change node
               let gn :: Int
gn = NodeSig -> Int
getNode NodeSig
nsig
                   changes :: [DGChange]
changes = Int -> [DGChange]
changeConsStatus Int
gn
               [DGChange] -> IO ()
updateDG [DGChange]
changes
               GInfo -> [Int] -> IO ()
checkConsAux GInfo
gInfo [Int]
ns
              UnitSig _ _ Nothing -> [Char] -> IO ()
forall a. HasCallStack => [Char] -> a
error "consCheck2"
              UnitSig _nsigs :: [NodeSig]
_nsigs nsig :: NodeSig
nsig (Just usig' :: NodeSig
usig') -> do
                let ss :: Int
ss = NodeSig -> Int
getNode NodeSig
usig'
                    tt :: Int
tt = NodeSig -> Int
getNode NodeSig
nsig
                    lEdges :: [(Int, Int, DGLinkLab)]
lEdges = ((Int, Int, DGLinkLab) -> Bool)
-> [(Int, Int, DGLinkLab)] -> [(Int, Int, DGLinkLab)]
forall a. (a -> Bool) -> [a] -> [a]
filter (\ (x :: Int
x, y :: Int
y, _) -> Int
x Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
ss Bool -> Bool -> Bool
&& Int
y Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
tt)
                              ([(Int, Int, DGLinkLab)] -> [(Int, Int, DGLinkLab)])
-> [(Int, Int, DGLinkLab)] -> [(Int, Int, DGLinkLab)]
forall a b. (a -> b) -> a -> b
$ Gr DGNodeLab DGLinkLab -> [(Int, Int, DGLinkLab)]
forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> [LEdge b]
labEdges (Gr DGNodeLab DGLinkLab -> [(Int, Int, DGLinkLab)])
-> Gr DGNodeLab DGLinkLab -> [(Int, Int, DGLinkLab)]
forall a b. (a -> b) -> a -> b
$ DGraph -> Gr DGNodeLab DGLinkLab
dgBody DGraph
dg
                    ll :: (Int, Int, DGLinkLab)
ll = if [(Int, Int, DGLinkLab)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Int, Int, DGLinkLab)]
lEdges then
                            [Char] -> (Int, Int, DGLinkLab)
forall a. HasCallStack => [Char] -> a
error "consCheck1"
                         else [(Int, Int, DGLinkLab)] -> (Int, Int, DGLinkLab)
forall a. [a] -> a
head [(Int, Int, DGLinkLab)]
lEdges   -- parametric unit, change edge
                    changes :: [DGChange]
changes = (Int, Int, DGLinkLab) -> [DGChange]
consLinks (Int, Int, DGLinkLab)
ll
                [DGChange] -> IO ()
updateDG [DGChange]
changes
                GInfo -> [Int] -> IO ()
checkConsAux GInfo
gInfo [Int]
ns
          _ -> GInfo -> [Int] -> IO ()
checkConsAux GInfo
gInfo ([Int] -> IO ()) -> [Int] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Int]
units [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
++ [Int]
ns

showSpec :: DGraph -> Int -> IO ()
showSpec :: DGraph -> Int -> IO ()
showSpec dg :: DGraph
dg n :: Int
n =
    [Char] -> [Char] -> IO ()
createTextDisplay "" (RTNodeLab -> [Char] -> [Char]
forall a. Pretty a => a -> [Char] -> [Char]
showDoc (DGraph -> Int -> RTNodeLab
labRT DGraph
dg Int
n) "")

showDiagram :: GInfo -> DGraph -> Int -> IO ()
showDiagram :: GInfo -> DGraph -> Int -> IO ()
showDiagram gInfo :: GInfo
gInfo dg :: DGraph
dg n :: Int
n = do
 let asDiags :: Map [Char] Diag
asDiags = DGraph -> Map [Char] Diag
archSpecDiags DGraph
dg
     rtlab :: RTNodeLab
rtlab = DGraph -> Int -> RTNodeLab
labRT DGraph
dg Int
n
     name :: [Char]
name = RTNodeLab -> [Char]
rtn_diag RTNodeLab
rtlab
 Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([Char]
name [Char] -> [[Char]] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` Map [Char] Diag -> [[Char]]
forall k a. Map k a -> [k]
Map.keys Map [Char] Diag
asDiags) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      IORef
  (Graph
     DaVinciGraph
     DaVinciGraphParms
     DaVinciNode
     DaVinciNodeType
     DaVinciNodeTypeParms
     DaVinciArc
     DaVinciArcType
     DaVinciArcTypeParms)
graph <- Graph
  DaVinciGraph
  DaVinciGraphParms
  DaVinciNode
  DaVinciNodeType
  DaVinciNodeTypeParms
  DaVinciArc
  DaVinciArcType
  DaVinciArcTypeParms
-> IO
     (IORef
        (Graph
           DaVinciGraph
           DaVinciGraphParms
           DaVinciNode
           DaVinciNodeType
           DaVinciNodeTypeParms
           DaVinciArc
           DaVinciArcType
           DaVinciArcTypeParms))
forall a. a -> IO (IORef a)
newIORef Graph
  DaVinciGraph
  DaVinciGraphParms
  DaVinciNode
  DaVinciNodeType
  DaVinciNodeTypeParms
  DaVinciArc
  DaVinciArcType
  DaVinciArcTypeParms
daVinciSort
      IORef NodeEdgeListDep
nodesEdges <- NodeEdgeListDep -> IO (IORef NodeEdgeListDep)
forall a. a -> IO (IORef a)
newIORef (([], []) :: NodeEdgeListDep)
      let
       globalMenu :: GlobalMenu
globalMenu =
        MenuPrim (Maybe [Char]) (IO ()) -> GlobalMenu
GlobalMenu (Maybe [Char]
-> [MenuPrim (Maybe [Char]) (IO ())]
-> MenuPrim (Maybe [Char]) (IO ())
forall subMenuValue value.
subMenuValue
-> [MenuPrim subMenuValue value] -> MenuPrim subMenuValue value
UDG.Menu Maybe [Char]
forall a. Maybe a
Nothing
          [])
       graphParms :: DaVinciGraphParms
graphParms = GlobalMenu
globalMenu GlobalMenu -> DaVinciGraphParms -> DaVinciGraphParms
forall option configuration.
HasConfig option configuration =>
option -> configuration -> configuration
$$
                   [Char] -> GraphTitle
GraphTitle ("Dependency Diagram for " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
name) GraphTitle -> DaVinciGraphParms -> DaVinciGraphParms
forall option configuration.
HasConfig option configuration =>
option -> configuration -> configuration
$$
                   Bool -> OptimiseLayout
OptimiseLayout Bool
True OptimiseLayout -> DaVinciGraphParms -> DaVinciGraphParms
forall option configuration.
HasConfig option configuration =>
option -> configuration -> configuration
$$
                   IO Bool -> AllowClose
AllowClose (Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True) AllowClose -> DaVinciGraphParms -> DaVinciGraphParms
forall option configuration.
HasConfig option configuration =>
option -> configuration -> configuration
$$
                   DaVinciGraphParms
forall graphParms. GraphParms graphParms => graphParms
emptyGraphParms
      Graph
  DaVinciGraph
  DaVinciGraphParms
  DaVinciNode
  DaVinciNodeType
  DaVinciNodeTypeParms
  DaVinciArc
  DaVinciArcType
  DaVinciArcTypeParms
graph' <- Graph
  DaVinciGraph
  DaVinciGraphParms
  DaVinciNode
  DaVinciNodeType
  DaVinciNodeTypeParms
  DaVinciArc
  DaVinciArcType
  DaVinciArcTypeParms
-> DaVinciGraphParms
-> IO
     (Graph
        DaVinciGraph
        DaVinciGraphParms
        DaVinciNode
        DaVinciNodeType
        DaVinciNodeTypeParms
        DaVinciArc
        DaVinciArcType
        DaVinciArcTypeParms)
forall graph graphParms (node :: * -> *) (nodeType :: * -> *)
       (nodeTypeParms :: * -> *) (arc :: * -> *) (arcType :: * -> *)
       (arcTypeParms :: * -> *).
GraphAll
  graph
  graphParms
  node
  nodeType
  nodeTypeParms
  arc
  arcType
  arcTypeParms =>
Graph
  graph
  graphParms
  node
  nodeType
  nodeTypeParms
  arc
  arcType
  arcTypeParms
-> graphParms
-> IO
     (Graph
        graph
        graphParms
        node
        nodeType
        nodeTypeParms
        arc
        arcType
        arcTypeParms)
newGraph Graph
  DaVinciGraph
  DaVinciGraphParms
  DaVinciNode
  DaVinciNodeType
  DaVinciNodeTypeParms
  DaVinciArc
  DaVinciArcType
  DaVinciArcTypeParms
daVinciSort DaVinciGraphParms
graphParms
      DGraph
-> Diag
-> Graph
     DaVinciGraph
     DaVinciGraphParms
     DaVinciNode
     DaVinciNodeType
     DaVinciNodeTypeParms
     DaVinciArc
     DaVinciArcType
     DaVinciArcTypeParms
-> GInfo
-> IORef NodeEdgeListDep
-> IO ()
addNodesAndEdgesDeps DGraph
dg (Diag -> [Char] -> Map [Char] Diag -> Diag
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault ([Char] -> Diag
forall a. HasCallStack => [Char] -> a
error "showDiagram")
                            [Char]
name Map [Char] Diag
asDiags)
                           Graph
  DaVinciGraph
  DaVinciGraphParms
  DaVinciNode
  DaVinciNodeType
  DaVinciNodeTypeParms
  DaVinciArc
  DaVinciArcType
  DaVinciArcTypeParms
graph' GInfo
gInfo IORef NodeEdgeListDep
nodesEdges
      IORef
  (Graph
     DaVinciGraph
     DaVinciGraphParms
     DaVinciNode
     DaVinciNodeType
     DaVinciNodeTypeParms
     DaVinciArc
     DaVinciArcType
     DaVinciArcTypeParms)
-> Graph
     DaVinciGraph
     DaVinciGraphParms
     DaVinciNode
     DaVinciNodeType
     DaVinciNodeTypeParms
     DaVinciArc
     DaVinciArcType
     DaVinciArcTypeParms
-> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef
  (Graph
     DaVinciGraph
     DaVinciGraphParms
     DaVinciNode
     DaVinciNodeType
     DaVinciNodeTypeParms
     DaVinciArc
     DaVinciArcType
     DaVinciArcTypeParms)
graph Graph
  DaVinciGraph
  DaVinciGraphParms
  DaVinciNode
  DaVinciNodeType
  DaVinciNodeTypeParms
  DaVinciArc
  DaVinciArcType
  DaVinciArcTypeParms
graph'
      Graph
  DaVinciGraph
  DaVinciGraphParms
  DaVinciNode
  DaVinciNodeType
  DaVinciNodeTypeParms
  DaVinciArc
  DaVinciArcType
  DaVinciArcTypeParms
-> IO ()
forall graph graphParms (node :: * -> *) (nodeType :: * -> *)
       (nodeTypeParms :: * -> *) (arc :: * -> *) (arcType :: * -> *)
       (arcTypeParms :: * -> *).
GraphAll
  graph
  graphParms
  node
  nodeType
  nodeTypeParms
  arc
  arcType
  arcTypeParms =>
Graph
  graph
  graphParms
  node
  nodeType
  nodeTypeParms
  arc
  arcType
  arcTypeParms
-> IO ()
redraw Graph
  DaVinciGraph
  DaVinciGraphParms
  DaVinciNode
  DaVinciNodeType
  DaVinciNodeTypeParms
  DaVinciArc
  DaVinciArcType
  DaVinciArcTypeParms
graph'
 
showDiagSpec :: DGraph -> DiagNodeLab -> IO ()
showDiagSpec :: DGraph -> DiagNodeLab -> IO ()
showDiagSpec dg :: DGraph
dg l :: DiagNodeLab
l = do
 let NodeSig n :: Int
n _ = DiagNodeLab -> NodeSig
dn_sig DiagNodeLab
l
     nlab :: DGNodeLab
nlab = DGraph -> Int -> DGNodeLab
labDG DGraph
dg Int
n
     g1 :: G_theory
g1 = DGNodeLab -> G_theory
globOrLocTh DGNodeLab
nlab
 [Char] -> [Char] -> IO ()
createTextDisplay ""
   ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ "Desc:\n" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ DiagNodeLab -> [Char]
dn_desc DiagNodeLab
l [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ "\n" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
    "Sig:\n" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ G_theory -> [Char] -> [Char]
forall a. Pretty a => a -> [Char] -> [Char]
showDoc G_theory
g1 ""

addNodesAndEdgesDeps :: DGraph -> Diag -> DaVinciGraphTypeSyn -> GInfo ->
                       IORef NodeEdgeListDep -> IO ()
addNodesAndEdgesDeps :: DGraph
-> Diag
-> Graph
     DaVinciGraph
     DaVinciGraphParms
     DaVinciNode
     DaVinciNodeType
     DaVinciNodeTypeParms
     DaVinciArc
     DaVinciArcType
     DaVinciArcTypeParms
-> GInfo
-> IORef NodeEdgeListDep
-> IO ()
addNodesAndEdgesDeps dg :: DGraph
dg diag :: Diag
diag graph :: Graph
  DaVinciGraph
  DaVinciGraphParms
  DaVinciNode
  DaVinciNodeType
  DaVinciNodeTypeParms
  DaVinciArc
  DaVinciArcType
  DaVinciArcTypeParms
graph gi :: GInfo
gi nodesEdges :: IORef NodeEdgeListDep
nodesEdges = do
   let
    opts :: HetcatsOpts
opts = GInfo -> HetcatsOpts
hetcatsOpts GInfo
gi
    vertexes :: [DiagNodeLab]
vertexes = ((Int, DiagNodeLab) -> DiagNodeLab)
-> [(Int, DiagNodeLab)] -> [DiagNodeLab]
forall a b. (a -> b) -> [a] -> [b]
map (Int, DiagNodeLab) -> DiagNodeLab
forall a b. (a, b) -> b
snd ([(Int, DiagNodeLab)] -> [DiagNodeLab])
-> [(Int, DiagNodeLab)] -> [DiagNodeLab]
forall a b. (a -> b) -> a -> b
$ Gr DiagNodeLab DiagLinkLab -> [(Int, DiagNodeLab)]
forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> [LNode a]
Tree.labNodes (Gr DiagNodeLab DiagLinkLab -> [(Int, DiagNodeLab)])
-> Gr DiagNodeLab DiagLinkLab -> [(Int, DiagNodeLab)]
forall a b. (a -> b) -> a -> b
$ Diag -> Gr DiagNodeLab DiagLinkLab
diagGraph Diag
diag
    arcs :: [LEdge DiagLinkLab]
arcs = Gr DiagNodeLab DiagLinkLab -> [LEdge DiagLinkLab]
forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> [LEdge b]
Tree.labEdges (Gr DiagNodeLab DiagLinkLab -> [LEdge DiagLinkLab])
-> Gr DiagNodeLab DiagLinkLab -> [LEdge DiagLinkLab]
forall a b. (a -> b) -> a -> b
$ Diag -> Gr DiagNodeLab DiagLinkLab
diagGraph Diag
diag
    subNodeMenu :: LocalMenu DiagNodeLab
subNodeMenu = MenuPrim (Maybe [Char]) (DiagNodeLab -> IO ())
-> LocalMenu DiagNodeLab
forall value.
MenuPrim (Maybe [Char]) (value -> IO ()) -> LocalMenu value
LocalMenu (Maybe [Char]
-> [MenuPrim (Maybe [Char]) (DiagNodeLab -> IO ())]
-> MenuPrim (Maybe [Char]) (DiagNodeLab -> IO ())
forall subMenuValue value.
subMenuValue
-> [MenuPrim subMenuValue value] -> MenuPrim subMenuValue value
UDG.Menu Maybe [Char]
forall a. Maybe a
Nothing [[Char]
-> (DiagNodeLab -> IO ())
-> MenuPrim (Maybe [Char]) (DiagNodeLab -> IO ())
forall subMenuValue value.
[Char] -> value -> MenuPrim subMenuValue value
Button "Show desc and sig" ((DiagNodeLab -> IO ())
 -> MenuPrim (Maybe [Char]) (DiagNodeLab -> IO ()))
-> (DiagNodeLab -> IO ())
-> MenuPrim (Maybe [Char]) (DiagNodeLab -> IO ())
forall a b. (a -> b) -> a -> b
$
                                DGraph -> DiagNodeLab -> IO ()
showDiagSpec DGraph
dg ])
    subNodeTypeParms :: DaVinciNodeTypeParms DiagNodeLab
subNodeTypeParms = LocalMenu DiagNodeLab
subNodeMenu LocalMenu DiagNodeLab
-> DaVinciNodeTypeParms DiagNodeLab
-> DaVinciNodeTypeParms DiagNodeLab
forall (option :: * -> *) (configuration :: * -> *) value.
(HasConfigValue option configuration, Typeable value) =>
option value -> configuration value -> configuration value
$$$
                       Shape DiagNodeLab
forall value. Shape value
Ellipse Shape DiagNodeLab
-> DaVinciNodeTypeParms DiagNodeLab
-> DaVinciNodeTypeParms DiagNodeLab
forall (option :: * -> *) (configuration :: * -> *) value.
(HasConfigValue option configuration, Typeable value) =>
option value -> configuration value -> configuration value
$$$
                       (DiagNodeLab -> IO [Char]) -> ValueTitle DiagNodeLab
forall value. (value -> IO [Char]) -> ValueTitle value
ValueTitle ([Char] -> IO [Char]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Char] -> IO [Char])
-> (DiagNodeLab -> [Char]) -> DiagNodeLab -> IO [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (\ x :: DiagNodeLab
x ->
                                   Int -> [Char] -> [Char]
forall a. Int -> [a] -> [a]
take 20 ((Char -> Bool) -> [Char] -> [Char]
forall a. (a -> Bool) -> [a] -> [a]
filter (\c :: Char
c -> Char -> Bool
isAlphaNum Char
c Bool -> Bool -> Bool
|| Char -> Bool
isSpace Char
c) ([Char] -> [Char]) -> [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$ DiagNodeLab -> [Char]
dn_desc DiagNodeLab
x) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ "..." )) ValueTitle DiagNodeLab
-> DaVinciNodeTypeParms DiagNodeLab
-> DaVinciNodeTypeParms DiagNodeLab
forall (option :: * -> *) (configuration :: * -> *) value.
(HasConfigValue option configuration, Typeable value) =>
option value -> configuration value -> configuration value
$$$
                       [Char] -> Color DiagNodeLab
forall value. [Char] -> Color value
Color (HetcatsOpts -> Colors -> Bool -> Bool -> [Char]
getColor HetcatsOpts
opts Colors
Green Bool
True Bool
True) Color DiagNodeLab
-> DaVinciNodeTypeParms DiagNodeLab
-> DaVinciNodeTypeParms DiagNodeLab
forall (option :: * -> *) (configuration :: * -> *) value.
(HasConfigValue option configuration, Typeable value) =>
option value -> configuration value -> configuration value
$$$
                       DaVinciNodeTypeParms DiagNodeLab
forall (nodeTypeParms :: * -> *) value.
(NodeTypeParms nodeTypeParms, Typeable value) =>
nodeTypeParms value
emptyNodeTypeParms
   DaVinciNodeType DiagNodeLab
subNodeType <- Graph
  DaVinciGraph
  DaVinciGraphParms
  DaVinciNode
  DaVinciNodeType
  DaVinciNodeTypeParms
  DaVinciArc
  DaVinciArcType
  DaVinciArcTypeParms
-> DaVinciNodeTypeParms DiagNodeLab
-> IO (DaVinciNodeType DiagNodeLab)
forall graph graphParms (node :: * -> *) (nodeType :: * -> *)
       (nodeTypeParms :: * -> *) (arc :: * -> *) (arcType :: * -> *)
       (arcTypeParms :: * -> *) value.
(GraphAll
   graph
   graphParms
   node
   nodeType
   nodeTypeParms
   arc
   arcType
   arcTypeParms,
 Typeable value) =>
Graph
  graph
  graphParms
  node
  nodeType
  nodeTypeParms
  arc
  arcType
  arcTypeParms
-> nodeTypeParms value -> IO (nodeType value)
newNodeType Graph
  DaVinciGraph
  DaVinciGraphParms
  DaVinciNode
  DaVinciNodeType
  DaVinciNodeTypeParms
  DaVinciArc
  DaVinciArcType
  DaVinciArcTypeParms
graph DaVinciNodeTypeParms DiagNodeLab
subNodeTypeParms
   [DaVinciNode DiagNodeLab]
subNodeList <- (DiagNodeLab -> IO (DaVinciNode DiagNodeLab))
-> [DiagNodeLab] -> IO [DaVinciNode DiagNodeLab]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Graph
  DaVinciGraph
  DaVinciGraphParms
  DaVinciNode
  DaVinciNodeType
  DaVinciNodeTypeParms
  DaVinciArc
  DaVinciArcType
  DaVinciArcTypeParms
-> DaVinciNodeType DiagNodeLab
-> DiagNodeLab
-> IO (DaVinciNode DiagNodeLab)
forall graph graphParms (node :: * -> *) (nodeType :: * -> *)
       (nodeTypeParms :: * -> *) (arc :: * -> *) (arcType :: * -> *)
       (arcTypeParms :: * -> *) value.
(GraphAll
   graph
   graphParms
   node
   nodeType
   nodeTypeParms
   arc
   arcType
   arcTypeParms,
 Typeable value) =>
Graph
  graph
  graphParms
  node
  nodeType
  nodeTypeParms
  arc
  arcType
  arcTypeParms
-> nodeType value -> value -> IO (node value)
newNode Graph
  DaVinciGraph
  DaVinciGraphParms
  DaVinciNode
  DaVinciNodeType
  DaVinciNodeTypeParms
  DaVinciArc
  DaVinciArcType
  DaVinciArcTypeParms
graph DaVinciNodeType DiagNodeLab
subNodeType) [DiagNodeLab]
vertexes
   let
    nodes' :: Map Int (DaVinciNode DiagNodeLab)
nodes' = [(Int, DaVinciNode DiagNodeLab)]
-> Map Int (DaVinciNode DiagNodeLab)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(Int, DaVinciNode DiagNodeLab)]
 -> Map Int (DaVinciNode DiagNodeLab))
-> [(Int, DaVinciNode DiagNodeLab)]
-> Map Int (DaVinciNode DiagNodeLab)
forall a b. (a -> b) -> a -> b
$ [Int]
-> [DaVinciNode DiagNodeLab] -> [(Int, DaVinciNode DiagNodeLab)]
forall a b. [a] -> [b] -> [(a, b)]
zip (Gr DiagNodeLab DiagLinkLab -> [Int]
forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> [Int]
Tree.nodes (Gr DiagNodeLab DiagLinkLab -> [Int])
-> Gr DiagNodeLab DiagLinkLab -> [Int]
forall a b. (a -> b) -> a -> b
$ Diag -> Gr DiagNodeLab DiagLinkLab
diagGraph Diag
diag) [DaVinciNode DiagNodeLab]
subNodeList
    subArcMenu :: LocalMenu value
subArcMenu = MenuPrim (Maybe [Char]) (value -> IO ()) -> LocalMenu value
forall value.
MenuPrim (Maybe [Char]) (value -> IO ()) -> LocalMenu value
LocalMenu (Maybe [Char]
-> [MenuPrim (Maybe [Char]) (value -> IO ())]
-> MenuPrim (Maybe [Char]) (value -> IO ())
forall subMenuValue value.
subMenuValue
-> [MenuPrim subMenuValue value] -> MenuPrim subMenuValue value
UDG.Menu Maybe [Char]
forall a. Maybe a
Nothing [])
    subArcTypeParms :: DaVinciArcTypeParms (IO [Char])
subArcTypeParms = LocalMenu (IO [Char])
forall value. LocalMenu value
subArcMenu LocalMenu (IO [Char])
-> DaVinciArcTypeParms (IO [Char])
-> DaVinciArcTypeParms (IO [Char])
forall (option :: * -> *) (configuration :: * -> *) value.
(HasConfigValue option configuration, Typeable value) =>
option value -> configuration value -> configuration value
$$$
                      (IO [Char] -> IO [Char]) -> ValueTitle (IO [Char])
forall value. (value -> IO [Char]) -> ValueTitle value
ValueTitle (IO [Char] -> IO [Char] -> IO [Char]
forall (m :: * -> *) a. Monad m => a -> m a
return (IO [Char] -> IO [Char] -> IO [Char])
-> IO [Char] -> IO [Char] -> IO [Char]
forall a b. (a -> b) -> a -> b
$ [Char] -> IO [Char]
forall (m :: * -> *) a. Monad m => a -> m a
return "") ValueTitle (IO [Char])
-> DaVinciArcTypeParms (IO [Char])
-> DaVinciArcTypeParms (IO [Char])
forall (option :: * -> *) (configuration :: * -> *) value.
(HasConfigValue option configuration, Typeable value) =>
option value -> configuration value -> configuration value
$$$
                      [Char] -> Color (IO [Char])
forall value. [Char] -> Color value
Color (HetcatsOpts -> Colors -> Bool -> Bool -> [Char]
getColor HetcatsOpts
opts Colors
Black Bool
False Bool
False) Color (IO [Char])
-> DaVinciArcTypeParms (IO [Char])
-> DaVinciArcTypeParms (IO [Char])
forall (option :: * -> *) (configuration :: * -> *) value.
(HasConfigValue option configuration, Typeable value) =>
option value -> configuration value -> configuration value
$$$
                      DaVinciArcTypeParms (IO [Char])
forall (arcTypeParms :: * -> *) value.
(ArcTypeParms arcTypeParms, Typeable value) =>
arcTypeParms value
emptyArcTypeParms
   DaVinciArcType (IO [Char])
subArcType <- Graph
  DaVinciGraph
  DaVinciGraphParms
  DaVinciNode
  DaVinciNodeType
  DaVinciNodeTypeParms
  DaVinciArc
  DaVinciArcType
  DaVinciArcTypeParms
-> DaVinciArcTypeParms (IO [Char])
-> IO (DaVinciArcType (IO [Char]))
forall graph graphParms (node :: * -> *) (nodeType :: * -> *)
       (nodeTypeParms :: * -> *) (arc :: * -> *) (arcType :: * -> *)
       (arcTypeParms :: * -> *) value.
(GraphAll
   graph
   graphParms
   node
   nodeType
   nodeTypeParms
   arc
   arcType
   arcTypeParms,
 Typeable value) =>
Graph
  graph
  graphParms
  node
  nodeType
  nodeTypeParms
  arc
  arcType
  arcTypeParms
-> arcTypeParms value -> IO (arcType value)
newArcType Graph
  DaVinciGraph
  DaVinciGraphParms
  DaVinciNode
  DaVinciNodeType
  DaVinciNodeTypeParms
  DaVinciArc
  DaVinciArcType
  DaVinciArcTypeParms
graph DaVinciArcTypeParms (IO [Char])
subArcTypeParms
   let insertSubArc :: (Int, Int, c) -> IO (DaVinciArc (IO [Char]))
insertSubArc (n1 :: Int
n1, n2 :: Int
n2, _e :: c
_e) = Graph
  DaVinciGraph
  DaVinciGraphParms
  DaVinciNode
  DaVinciNodeType
  DaVinciNodeTypeParms
  DaVinciArc
  DaVinciArcType
  DaVinciArcTypeParms
-> DaVinciArcType (IO [Char])
-> IO [Char]
-> DaVinciNode DiagNodeLab
-> DaVinciNode DiagNodeLab
-> IO (DaVinciArc (IO [Char]))
forall graph graphParms (node :: * -> *) (nodeType :: * -> *)
       (nodeTypeParms :: * -> *) (arc :: * -> *) (arcType :: * -> *)
       (arcTypeParms :: * -> *) value nodeFromValue nodeToValue.
(GraphAll
   graph
   graphParms
   node
   nodeType
   nodeTypeParms
   arc
   arcType
   arcTypeParms,
 Typeable value, Typeable nodeFromValue, Typeable nodeToValue) =>
Graph
  graph
  graphParms
  node
  nodeType
  nodeTypeParms
  arc
  arcType
  arcTypeParms
-> arcType value
-> value
-> node nodeFromValue
-> node nodeToValue
-> IO (arc value)
newArc Graph
  DaVinciGraph
  DaVinciGraphParms
  DaVinciNode
  DaVinciNodeType
  DaVinciNodeTypeParms
  DaVinciArc
  DaVinciArcType
  DaVinciArcTypeParms
graph DaVinciArcType (IO [Char])
subArcType
                                            ([Char] -> IO [Char]
forall (m :: * -> *) a. Monad m => a -> m a
return "")
                                            (Map Int (DaVinciNode DiagNodeLab) -> Int -> DaVinciNode DiagNodeLab
forall a b. Ord a => Map a b -> a -> b
lookup' Map Int (DaVinciNode DiagNodeLab)
nodes' Int
n1)
                                            (Map Int (DaVinciNode DiagNodeLab) -> Int -> DaVinciNode DiagNodeLab
forall a b. Ord a => Map a b -> a -> b
lookup' Map Int (DaVinciNode DiagNodeLab)
nodes' Int
n2)
   [DaVinciArc (IO [Char])]
subArcList <- (LEdge DiagLinkLab -> IO (DaVinciArc (IO [Char])))
-> [LEdge DiagLinkLab] -> IO [DaVinciArc (IO [Char])]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM LEdge DiagLinkLab -> IO (DaVinciArc (IO [Char]))
forall c. (Int, Int, c) -> IO (DaVinciArc (IO [Char]))
insertSubArc [LEdge DiagLinkLab]
arcs
   IORef NodeEdgeListDep -> NodeEdgeListDep -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef NodeEdgeListDep
nodesEdges ([DaVinciNode DiagNodeLab]
subNodeList, [DaVinciArc (IO [Char])]
subArcList)