{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE DeriveDataTypeable #-}

-- | GetAttributes is used by the GraphEditor to pop up HTk windows
-- to get information from the user.
module Graphs.GetAttributes(
   NodeTypeAttributes(..), -- instance of Typeable
   getNodeTypeAttributes, -- :: IO (Maybe NodeTypeAttributes)
   NodeAttributes(..), -- instance of Typeable
   getNodeAttributes, -- :: IO (Maybe NodeAttributes)
   ArcTypeAttributes(..), -- instance of Typeable
   getArcTypeAttributes, -- :: IO (Maybe ArcTypeAttributes)
   ArcAttributes(..), -- instance of Typeable
   getArcAttributes, -- :: IO (Maybe ArcAttributes)
   displayError, -- :: String -> IO ()
   ) where

import Control.Exception as Exception

import Util.Dynamics
import Util.Registry hiding (getValue)
import qualified Util.Registry as Registry (getValue)
import Util.Messages

import HTk.Toplevel.HTk hiding (Icon)
import HTk.Toolkit.InputWin
import HTk.Toolkit.InputForm

import qualified Graphs.GraphConfigure as GraphConfigure

------------------------------------------------------------------------
-- NodeTypes
------------------------------------------------------------------------

data ShapeSort = Box | Circle | Ellipse | Rhombus | Triangle | Icon
   deriving (Int -> ShapeSort
ShapeSort -> Int
ShapeSort -> [ShapeSort]
ShapeSort -> ShapeSort
ShapeSort -> ShapeSort -> [ShapeSort]
ShapeSort -> ShapeSort -> ShapeSort -> [ShapeSort]
(ShapeSort -> ShapeSort)
-> (ShapeSort -> ShapeSort)
-> (Int -> ShapeSort)
-> (ShapeSort -> Int)
-> (ShapeSort -> [ShapeSort])
-> (ShapeSort -> ShapeSort -> [ShapeSort])
-> (ShapeSort -> ShapeSort -> [ShapeSort])
-> (ShapeSort -> ShapeSort -> ShapeSort -> [ShapeSort])
-> Enum ShapeSort
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: ShapeSort -> ShapeSort -> ShapeSort -> [ShapeSort]
$cenumFromThenTo :: ShapeSort -> ShapeSort -> ShapeSort -> [ShapeSort]
enumFromTo :: ShapeSort -> ShapeSort -> [ShapeSort]
$cenumFromTo :: ShapeSort -> ShapeSort -> [ShapeSort]
enumFromThen :: ShapeSort -> ShapeSort -> [ShapeSort]
$cenumFromThen :: ShapeSort -> ShapeSort -> [ShapeSort]
enumFrom :: ShapeSort -> [ShapeSort]
$cenumFrom :: ShapeSort -> [ShapeSort]
fromEnum :: ShapeSort -> Int
$cfromEnum :: ShapeSort -> Int
toEnum :: Int -> ShapeSort
$ctoEnum :: Int -> ShapeSort
pred :: ShapeSort -> ShapeSort
$cpred :: ShapeSort -> ShapeSort
succ :: ShapeSort -> ShapeSort
$csucc :: ShapeSort -> ShapeSort
Enum,ReadPrec [ShapeSort]
ReadPrec ShapeSort
Int -> ReadS ShapeSort
ReadS [ShapeSort]
(Int -> ReadS ShapeSort)
-> ReadS [ShapeSort]
-> ReadPrec ShapeSort
-> ReadPrec [ShapeSort]
-> Read ShapeSort
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [ShapeSort]
$creadListPrec :: ReadPrec [ShapeSort]
readPrec :: ReadPrec ShapeSort
$creadPrec :: ReadPrec ShapeSort
readList :: ReadS [ShapeSort]
$creadList :: ReadS [ShapeSort]
readsPrec :: Int -> ReadS ShapeSort
$creadsPrec :: Int -> ReadS ShapeSort
Read,Int -> ShapeSort -> ShowS
[ShapeSort] -> ShowS
ShapeSort -> String
(Int -> ShapeSort -> ShowS)
-> (ShapeSort -> String)
-> ([ShapeSort] -> ShowS)
-> Show ShapeSort
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ShapeSort] -> ShowS
$cshowList :: [ShapeSort] -> ShowS
show :: ShapeSort -> String
$cshow :: ShapeSort -> String
showsPrec :: Int -> ShapeSort -> ShowS
$cshowsPrec :: Int -> ShapeSort -> ShowS
Show)

instance GUIValue ShapeSort where
   cdefault :: ShapeSort
cdefault = ShapeSort
Box

data NodeTypeAttributes nodeLabel = NodeTypeAttributes {
   NodeTypeAttributes nodeLabel -> Shape nodeLabel
shape :: GraphConfigure.Shape nodeLabel,
   NodeTypeAttributes nodeLabel -> String
nodeTypeTitle :: String
   } deriving (ReadPrec [NodeTypeAttributes nodeLabel]
ReadPrec (NodeTypeAttributes nodeLabel)
Int -> ReadS (NodeTypeAttributes nodeLabel)
ReadS [NodeTypeAttributes nodeLabel]
(Int -> ReadS (NodeTypeAttributes nodeLabel))
-> ReadS [NodeTypeAttributes nodeLabel]
-> ReadPrec (NodeTypeAttributes nodeLabel)
-> ReadPrec [NodeTypeAttributes nodeLabel]
-> Read (NodeTypeAttributes nodeLabel)
forall nodeLabel. ReadPrec [NodeTypeAttributes nodeLabel]
forall nodeLabel. ReadPrec (NodeTypeAttributes nodeLabel)
forall nodeLabel. Int -> ReadS (NodeTypeAttributes nodeLabel)
forall nodeLabel. ReadS [NodeTypeAttributes nodeLabel]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [NodeTypeAttributes nodeLabel]
$creadListPrec :: forall nodeLabel. ReadPrec [NodeTypeAttributes nodeLabel]
readPrec :: ReadPrec (NodeTypeAttributes nodeLabel)
$creadPrec :: forall nodeLabel. ReadPrec (NodeTypeAttributes nodeLabel)
readList :: ReadS [NodeTypeAttributes nodeLabel]
$creadList :: forall nodeLabel. ReadS [NodeTypeAttributes nodeLabel]
readsPrec :: Int -> ReadS (NodeTypeAttributes nodeLabel)
$creadsPrec :: forall nodeLabel. Int -> ReadS (NodeTypeAttributes nodeLabel)
Read,Int -> NodeTypeAttributes nodeLabel -> ShowS
[NodeTypeAttributes nodeLabel] -> ShowS
NodeTypeAttributes nodeLabel -> String
(Int -> NodeTypeAttributes nodeLabel -> ShowS)
-> (NodeTypeAttributes nodeLabel -> String)
-> ([NodeTypeAttributes nodeLabel] -> ShowS)
-> Show (NodeTypeAttributes nodeLabel)
forall nodeLabel. Int -> NodeTypeAttributes nodeLabel -> ShowS
forall nodeLabel. [NodeTypeAttributes nodeLabel] -> ShowS
forall nodeLabel. NodeTypeAttributes nodeLabel -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [NodeTypeAttributes nodeLabel] -> ShowS
$cshowList :: forall nodeLabel. [NodeTypeAttributes nodeLabel] -> ShowS
show :: NodeTypeAttributes nodeLabel -> String
$cshow :: forall nodeLabel. NodeTypeAttributes nodeLabel -> String
showsPrec :: Int -> NodeTypeAttributes nodeLabel -> ShowS
$cshowsPrec :: forall nodeLabel. Int -> NodeTypeAttributes nodeLabel -> ShowS
Show,Typeable)

data PreAttributes = PreAttributes {
   PreAttributes -> ShapeSort
shapeSort :: ShapeSort,
   PreAttributes -> String
nodeTypeTitle' :: String
   }

getNodeTypeAttributes :: IO (Maybe(NodeTypeAttributes nodeLabel))
getNodeTypeAttributes :: IO (Maybe (NodeTypeAttributes nodeLabel))
getNodeTypeAttributes =
   IO (NodeTypeAttributes nodeLabel)
-> IO (Maybe (NodeTypeAttributes nodeLabel))
forall a. IO a -> IO (Maybe a)
allowCancel (
      do
         PreAttributes {shapeSort :: PreAttributes -> ShapeSort
shapeSort=ShapeSort
shapeSort,nodeTypeTitle' :: PreAttributes -> String
nodeTypeTitle'=String
nodeTypeTitle} <-
            IO PreAttributes
getNodeTypeAttributes1

         Shape nodeLabel
shape <- case ShapeSort
shapeSort of
            ShapeSort
Box -> Shape nodeLabel -> IO (Shape nodeLabel)
forall (m :: * -> *) a. Monad m => a -> m a
return Shape nodeLabel
forall value. Shape value
GraphConfigure.Box
            ShapeSort
Circle -> Shape nodeLabel -> IO (Shape nodeLabel)
forall (m :: * -> *) a. Monad m => a -> m a
return Shape nodeLabel
forall value. Shape value
GraphConfigure.Circle
            ShapeSort
Ellipse -> Shape nodeLabel -> IO (Shape nodeLabel)
forall (m :: * -> *) a. Monad m => a -> m a
return Shape nodeLabel
forall value. Shape value
GraphConfigure.Ellipse
            ShapeSort
Rhombus -> Shape nodeLabel -> IO (Shape nodeLabel)
forall (m :: * -> *) a. Monad m => a -> m a
return Shape nodeLabel
forall value. Shape value
GraphConfigure.Rhombus
            ShapeSort
Triangle -> Shape nodeLabel -> IO (Shape nodeLabel)
forall (m :: * -> *) a. Monad m => a -> m a
return Shape nodeLabel
forall value. Shape value
GraphConfigure.Triangle
            ShapeSort
Icon ->
               do
                  String
fname <- String -> IO String
getSingleString String
"Icon filename"
                  Shape nodeLabel -> IO (Shape nodeLabel)
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Shape nodeLabel
forall value. String -> Shape value
GraphConfigure.Icon String
fname)

         NodeTypeAttributes nodeLabel -> IO (NodeTypeAttributes nodeLabel)
forall (m :: * -> *) a. Monad m => a -> m a
return NodeTypeAttributes :: forall nodeLabel.
Shape nodeLabel -> String -> NodeTypeAttributes nodeLabel
NodeTypeAttributes {shape :: Shape nodeLabel
shape=Shape nodeLabel
shape,nodeTypeTitle :: String
nodeTypeTitle=String
nodeTypeTitle}        )

getNodeTypeAttributes1 :: IO PreAttributes
-- This returns the sort of shape + the node type title.
getNodeTypeAttributes1 :: IO PreAttributes
getNodeTypeAttributes1 =
   do
      let def :: PreAttributes
def = PreAttributes :: ShapeSort -> String -> PreAttributes
PreAttributes {shapeSort :: ShapeSort
shapeSort=ShapeSort
Box,nodeTypeTitle' :: String
nodeTypeTitle'=String
""}
      (InputWin PreAttributes
iw, InputForm PreAttributes
form) <- String
-> (Box -> IO (InputForm PreAttributes))
-> [Config Toplevel]
-> IO (InputWin PreAttributes, InputForm PreAttributes)
forall a.
String
-> (Box -> IO (InputForm a))
-> [Config Toplevel]
-> IO (InputWin a, InputForm a)
createInputWin String
"Node Type Attributes"
                                (\Box
p-> Box
-> Maybe PreAttributes
-> [Config (InputForm PreAttributes)]
-> IO (InputForm PreAttributes)
forall a.
Box -> Maybe a -> [Config (InputForm a)] -> IO (InputForm a)
newInputForm Box
p (PreAttributes -> Maybe PreAttributes
forall a. a -> Maybe a
Just PreAttributes
def) []) []
      InputForm PreAttributes
-> [ShapeSort]
-> [Config (EnumField PreAttributes ShapeSort)]
-> IO (EnumField PreAttributes ShapeSort)
forall b a.
GUIValue b =>
InputForm a
-> [b] -> [Config (EnumField a b)] -> IO (EnumField a b)
newEnumField InputForm PreAttributes
form [ShapeSort
Box .. ShapeSort
Icon] [
         -- text "Node Shape",
         (PreAttributes -> ShapeSort)
-> Config (EnumField PreAttributes ShapeSort)
forall (f :: * -> * -> *) b a.
(InputField f, GUIValue b) =>
(a -> b) -> Config (f a b)
selector PreAttributes -> ShapeSort
shapeSort,
         (PreAttributes -> ShapeSort -> PreAttributes)
-> Config (EnumField PreAttributes ShapeSort)
forall (f :: * -> * -> *) b a.
(InputField f, GUIValue b) =>
(a -> b -> a) -> Config (f a b)
modifier (\ PreAttributes
old ShapeSort
newShape -> PreAttributes
old {shapeSort :: ShapeSort
shapeSort = ShapeSort
newShape})
         ]
      InputForm PreAttributes
-> [Config (EntryField PreAttributes String)]
-> IO (EntryField PreAttributes String)
forall b a.
GUIValue b =>
InputForm a -> [Config (EntryField a b)] -> IO (EntryField a b)
newEntryField InputForm PreAttributes
form [
         String -> Config (EntryField PreAttributes String)
forall w v. HasText w v => v -> Config w
text String
"Node Type title",
         (PreAttributes -> String)
-> Config (EntryField PreAttributes String)
forall (f :: * -> * -> *) b a.
(InputField f, GUIValue b) =>
(a -> b) -> Config (f a b)
selector PreAttributes -> String
nodeTypeTitle',
         (PreAttributes -> String -> PreAttributes)
-> Config (EntryField PreAttributes String)
forall (f :: * -> * -> *) b a.
(InputField f, GUIValue b) =>
(a -> b -> a) -> Config (f a b)
modifier (\ PreAttributes
old String
newTitle -> PreAttributes
old {nodeTypeTitle' :: String
nodeTypeTitle' = String
newTitle}),
         Distance -> Config (EntryField PreAttributes String)
forall w. HasSize w => Distance -> Config w
width Distance
20
         ]
      Maybe PreAttributes
result <- InputWin PreAttributes -> Bool -> IO (Maybe PreAttributes)
forall a. InputWin a -> Bool -> IO (Maybe a)
wait InputWin PreAttributes
iw Bool
True
      case Maybe PreAttributes
result of
         Just PreAttributes
value -> PreAttributes -> IO PreAttributes
forall (m :: * -> *) a. Monad m => a -> m a
return PreAttributes
value
         Maybe PreAttributes
Nothing -> IO PreAttributes
forall anything. IO anything
cancelQuery

------------------------------------------------------------------------
-- Nodes
------------------------------------------------------------------------

data NodeAttributes nodeType = NodeAttributes {
   NodeAttributes nodeType -> nodeType
nodeType :: nodeType,
   NodeAttributes nodeType -> String
nodeTitle :: String
   } deriving (ReadPrec [NodeAttributes nodeType]
ReadPrec (NodeAttributes nodeType)
Int -> ReadS (NodeAttributes nodeType)
ReadS [NodeAttributes nodeType]
(Int -> ReadS (NodeAttributes nodeType))
-> ReadS [NodeAttributes nodeType]
-> ReadPrec (NodeAttributes nodeType)
-> ReadPrec [NodeAttributes nodeType]
-> Read (NodeAttributes nodeType)
forall nodeType.
Read nodeType =>
ReadPrec [NodeAttributes nodeType]
forall nodeType.
Read nodeType =>
ReadPrec (NodeAttributes nodeType)
forall nodeType.
Read nodeType =>
Int -> ReadS (NodeAttributes nodeType)
forall nodeType. Read nodeType => ReadS [NodeAttributes nodeType]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [NodeAttributes nodeType]
$creadListPrec :: forall nodeType.
Read nodeType =>
ReadPrec [NodeAttributes nodeType]
readPrec :: ReadPrec (NodeAttributes nodeType)
$creadPrec :: forall nodeType.
Read nodeType =>
ReadPrec (NodeAttributes nodeType)
readList :: ReadS [NodeAttributes nodeType]
$creadList :: forall nodeType. Read nodeType => ReadS [NodeAttributes nodeType]
readsPrec :: Int -> ReadS (NodeAttributes nodeType)
$creadsPrec :: forall nodeType.
Read nodeType =>
Int -> ReadS (NodeAttributes nodeType)
Read,Int -> NodeAttributes nodeType -> ShowS
[NodeAttributes nodeType] -> ShowS
NodeAttributes nodeType -> String
(Int -> NodeAttributes nodeType -> ShowS)
-> (NodeAttributes nodeType -> String)
-> ([NodeAttributes nodeType] -> ShowS)
-> Show (NodeAttributes nodeType)
forall nodeType.
Show nodeType =>
Int -> NodeAttributes nodeType -> ShowS
forall nodeType.
Show nodeType =>
[NodeAttributes nodeType] -> ShowS
forall nodeType. Show nodeType => NodeAttributes nodeType -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [NodeAttributes nodeType] -> ShowS
$cshowList :: forall nodeType.
Show nodeType =>
[NodeAttributes nodeType] -> ShowS
show :: NodeAttributes nodeType -> String
$cshow :: forall nodeType. Show nodeType => NodeAttributes nodeType -> String
showsPrec :: Int -> NodeAttributes nodeType -> ShowS
$cshowsPrec :: forall nodeType.
Show nodeType =>
Int -> NodeAttributes nodeType -> ShowS
Show,Typeable)

data NodePreAttributes = NodePreAttributes {
   NodePreAttributes -> String
preNodeType :: String,
   NodePreAttributes -> String
preNodeTitle :: String
   } deriving Int -> NodePreAttributes -> ShowS
[NodePreAttributes] -> ShowS
NodePreAttributes -> String
(Int -> NodePreAttributes -> ShowS)
-> (NodePreAttributes -> String)
-> ([NodePreAttributes] -> ShowS)
-> Show NodePreAttributes
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [NodePreAttributes] -> ShowS
$cshowList :: [NodePreAttributes] -> ShowS
show :: NodePreAttributes -> String
$cshow :: NodePreAttributes -> String
showsPrec :: Int -> NodePreAttributes -> ShowS
$cshowsPrec :: Int -> NodePreAttributes -> ShowS
Show

getNodeAttributes :: (Registry String nodeType) ->
   IO (Maybe (NodeAttributes nodeType))
-- getNodeAttributes gets the required attributes of a node given
-- its possible types (with their titles).
getNodeAttributes :: Registry String nodeType -> IO (Maybe (NodeAttributes nodeType))
getNodeAttributes Registry String nodeType
registry =
   IO (NodeAttributes nodeType)
-> IO (Maybe (NodeAttributes nodeType))
forall a. IO a -> IO (Maybe a)
allowCancel (
      do
         [String]
knownTypeNames <- Registry String nodeType -> IO [String]
forall registry from.
KeyOpsRegistry registry from =>
registry -> IO [from]
listKeys Registry String nodeType
registry
         case [String]
knownTypeNames of
            [] ->
               do
                  String -> IO ()
displayError String
"You must first define some node types"
                  IO ()
forall anything. IO anything
cancelQuery
            [String]
_ -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
         let
            def :: NodePreAttributes
def = NodePreAttributes :: String -> String -> NodePreAttributes
NodePreAttributes {
               preNodeType :: String
preNodeType=[String] -> String
forall a. [a] -> a
head [String]
knownTypeNames,
               preNodeTitle :: String
preNodeTitle=String
""
               }
            -- iform p = newInputForm p (Just def) []
         (InputWin NodePreAttributes
inputWin, InputForm NodePreAttributes
form) <- String
-> (Box -> IO (InputForm NodePreAttributes))
-> [Config Toplevel]
-> IO (InputWin NodePreAttributes, InputForm NodePreAttributes)
forall a.
String
-> (Box -> IO (InputForm a))
-> [Config Toplevel]
-> IO (InputWin a, InputForm a)
createInputWin String
"Node Attributes"
                                         (\Box
p-> Box
-> Maybe NodePreAttributes
-> [Config (InputForm NodePreAttributes)]
-> IO (InputForm NodePreAttributes)
forall a.
Box -> Maybe a -> [Config (InputForm a)] -> IO (InputForm a)
newInputForm Box
p (NodePreAttributes -> Maybe NodePreAttributes
forall a. a -> Maybe a
Just NodePreAttributes
def) []) []
         InputForm NodePreAttributes
-> [String]
-> [Config (EnumField NodePreAttributes String)]
-> IO (EnumField NodePreAttributes String)
forall b a.
GUIValue b =>
InputForm a
-> [b] -> [Config (EnumField a b)] -> IO (EnumField a b)
newEnumField InputForm NodePreAttributes
form [String]
knownTypeNames [
            -- text "Node Type",
            (NodePreAttributes -> String)
-> Config (EnumField NodePreAttributes String)
forall (f :: * -> * -> *) b a.
(InputField f, GUIValue b) =>
(a -> b) -> Config (f a b)
selector NodePreAttributes -> String
preNodeType,
            (NodePreAttributes -> String -> NodePreAttributes)
-> Config (EnumField NodePreAttributes String)
forall (f :: * -> * -> *) b a.
(InputField f, GUIValue b) =>
(a -> b -> a) -> Config (f a b)
modifier (\ NodePreAttributes
old String
nodeTypeName ->
               NodePreAttributes
old {preNodeType :: String
preNodeType = String
nodeTypeName})
            ]
         InputForm NodePreAttributes
-> [Config (EntryField NodePreAttributes String)]
-> IO (EntryField NodePreAttributes String)
forall b a.
GUIValue b =>
InputForm a -> [Config (EntryField a b)] -> IO (EntryField a b)
newEntryField InputForm NodePreAttributes
form [
            String -> Config (EntryField NodePreAttributes String)
forall w v. HasText w v => v -> Config w
text String
"Node title",
            (NodePreAttributes -> String)
-> Config (EntryField NodePreAttributes String)
forall (f :: * -> * -> *) b a.
(InputField f, GUIValue b) =>
(a -> b) -> Config (f a b)
selector NodePreAttributes -> String
preNodeTitle,
            (NodePreAttributes -> String -> NodePreAttributes)
-> Config (EntryField NodePreAttributes String)
forall (f :: * -> * -> *) b a.
(InputField f, GUIValue b) =>
(a -> b -> a) -> Config (f a b)
modifier (\ NodePreAttributes
old String
newTitle -> NodePreAttributes
old {preNodeTitle :: String
preNodeTitle = String
newTitle}),
            Distance -> Config (EntryField NodePreAttributes String)
forall w. HasSize w => Distance -> Config w
width Distance
20
            ]
         Maybe NodePreAttributes
result <- InputWin NodePreAttributes -> Bool -> IO (Maybe NodePreAttributes)
forall a. InputWin a -> Bool -> IO (Maybe a)
wait InputWin NodePreAttributes
inputWin Bool
True
         case Maybe NodePreAttributes
result of
            Just (NodePreAttributes {
               preNodeTitle :: NodePreAttributes -> String
preNodeTitle = String
nodeTitle,
               preNodeType :: NodePreAttributes -> String
preNodeType = String
nodeTypeName
               }) ->
                  do
                     nodeType
nodeType <- Registry String nodeType -> String -> IO nodeType
forall registry from to.
GetSetRegistry registry from to =>
registry -> from -> IO to
Registry.getValue Registry String nodeType
registry String
nodeTypeName
                     NodeAttributes nodeType -> IO (NodeAttributes nodeType)
forall (m :: * -> *) a. Monad m => a -> m a
return (NodeAttributes :: forall nodeType. nodeType -> String -> NodeAttributes nodeType
NodeAttributes {
                        nodeTitle :: String
nodeTitle = String
nodeTitle,
                        nodeType :: nodeType
nodeType = nodeType
nodeType
                        })
            Maybe NodePreAttributes
Nothing -> IO (NodeAttributes nodeType)
forall anything. IO anything
cancelQuery
      )

------------------------------------------------------------------------
-- Arc Types
------------------------------------------------------------------------

data ArcTypeAttributes = ArcTypeAttributes {
   ArcTypeAttributes -> String
arcTypeTitle :: String
   } deriving (ReadPrec [ArcTypeAttributes]
ReadPrec ArcTypeAttributes
Int -> ReadS ArcTypeAttributes
ReadS [ArcTypeAttributes]
(Int -> ReadS ArcTypeAttributes)
-> ReadS [ArcTypeAttributes]
-> ReadPrec ArcTypeAttributes
-> ReadPrec [ArcTypeAttributes]
-> Read ArcTypeAttributes
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [ArcTypeAttributes]
$creadListPrec :: ReadPrec [ArcTypeAttributes]
readPrec :: ReadPrec ArcTypeAttributes
$creadPrec :: ReadPrec ArcTypeAttributes
readList :: ReadS [ArcTypeAttributes]
$creadList :: ReadS [ArcTypeAttributes]
readsPrec :: Int -> ReadS ArcTypeAttributes
$creadsPrec :: Int -> ReadS ArcTypeAttributes
Read,Int -> ArcTypeAttributes -> ShowS
[ArcTypeAttributes] -> ShowS
ArcTypeAttributes -> String
(Int -> ArcTypeAttributes -> ShowS)
-> (ArcTypeAttributes -> String)
-> ([ArcTypeAttributes] -> ShowS)
-> Show ArcTypeAttributes
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ArcTypeAttributes] -> ShowS
$cshowList :: [ArcTypeAttributes] -> ShowS
show :: ArcTypeAttributes -> String
$cshow :: ArcTypeAttributes -> String
showsPrec :: Int -> ArcTypeAttributes -> ShowS
$cshowsPrec :: Int -> ArcTypeAttributes -> ShowS
Show,Typeable)

getArcTypeAttributes :: IO (Maybe ArcTypeAttributes)
getArcTypeAttributes :: IO (Maybe ArcTypeAttributes)
getArcTypeAttributes =
   do
      let def :: ArcTypeAttributes
def = ArcTypeAttributes :: String -> ArcTypeAttributes
ArcTypeAttributes {arcTypeTitle :: String
arcTypeTitle=String
""}
      (InputWin ArcTypeAttributes
iw, InputForm ArcTypeAttributes
form) <- String
-> (Box -> IO (InputForm ArcTypeAttributes))
-> [Config Toplevel]
-> IO (InputWin ArcTypeAttributes, InputForm ArcTypeAttributes)
forall a.
String
-> (Box -> IO (InputForm a))
-> [Config Toplevel]
-> IO (InputWin a, InputForm a)
createInputWin String
"Arc Type Attributes"
                                (\Box
p-> Box
-> Maybe ArcTypeAttributes
-> [Config (InputForm ArcTypeAttributes)]
-> IO (InputForm ArcTypeAttributes)
forall a.
Box -> Maybe a -> [Config (InputForm a)] -> IO (InputForm a)
newInputForm Box
p (ArcTypeAttributes -> Maybe ArcTypeAttributes
forall a. a -> Maybe a
Just ArcTypeAttributes
def) []) []
      InputForm ArcTypeAttributes
-> [Config (EntryField ArcTypeAttributes String)]
-> IO (EntryField ArcTypeAttributes String)
forall b a.
GUIValue b =>
InputForm a -> [Config (EntryField a b)] -> IO (EntryField a b)
newEntryField InputForm ArcTypeAttributes
form [
         String -> Config (EntryField ArcTypeAttributes String)
forall w v. HasText w v => v -> Config w
text String
"Arc Type title",
         (ArcTypeAttributes -> String)
-> Config (EntryField ArcTypeAttributes String)
forall (f :: * -> * -> *) b a.
(InputField f, GUIValue b) =>
(a -> b) -> Config (f a b)
selector ArcTypeAttributes -> String
arcTypeTitle,
         (ArcTypeAttributes -> String -> ArcTypeAttributes)
-> Config (EntryField ArcTypeAttributes String)
forall (f :: * -> * -> *) b a.
(InputField f, GUIValue b) =>
(a -> b -> a) -> Config (f a b)
modifier (\ ArcTypeAttributes
old String
newTitle -> ArcTypeAttributes
old {arcTypeTitle :: String
arcTypeTitle = String
newTitle}),
         Distance -> Config (EntryField ArcTypeAttributes String)
forall w. HasSize w => Distance -> Config w
width Distance
20
         ]
      InputWin ArcTypeAttributes -> Bool -> IO (Maybe ArcTypeAttributes)
forall a. InputWin a -> Bool -> IO (Maybe a)
wait InputWin ArcTypeAttributes
iw Bool
True

------------------------------------------------------------------------
-- Arcs
------------------------------------------------------------------------

data ArcAttributes arcType = ArcAttributes {
   ArcAttributes arcType -> arcType
arcType :: arcType
   } deriving (ReadPrec [ArcAttributes arcType]
ReadPrec (ArcAttributes arcType)
Int -> ReadS (ArcAttributes arcType)
ReadS [ArcAttributes arcType]
(Int -> ReadS (ArcAttributes arcType))
-> ReadS [ArcAttributes arcType]
-> ReadPrec (ArcAttributes arcType)
-> ReadPrec [ArcAttributes arcType]
-> Read (ArcAttributes arcType)
forall arcType. Read arcType => ReadPrec [ArcAttributes arcType]
forall arcType. Read arcType => ReadPrec (ArcAttributes arcType)
forall arcType.
Read arcType =>
Int -> ReadS (ArcAttributes arcType)
forall arcType. Read arcType => ReadS [ArcAttributes arcType]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [ArcAttributes arcType]
$creadListPrec :: forall arcType. Read arcType => ReadPrec [ArcAttributes arcType]
readPrec :: ReadPrec (ArcAttributes arcType)
$creadPrec :: forall arcType. Read arcType => ReadPrec (ArcAttributes arcType)
readList :: ReadS [ArcAttributes arcType]
$creadList :: forall arcType. Read arcType => ReadS [ArcAttributes arcType]
readsPrec :: Int -> ReadS (ArcAttributes arcType)
$creadsPrec :: forall arcType.
Read arcType =>
Int -> ReadS (ArcAttributes arcType)
Read,Int -> ArcAttributes arcType -> ShowS
[ArcAttributes arcType] -> ShowS
ArcAttributes arcType -> String
(Int -> ArcAttributes arcType -> ShowS)
-> (ArcAttributes arcType -> String)
-> ([ArcAttributes arcType] -> ShowS)
-> Show (ArcAttributes arcType)
forall arcType.
Show arcType =>
Int -> ArcAttributes arcType -> ShowS
forall arcType. Show arcType => [ArcAttributes arcType] -> ShowS
forall arcType. Show arcType => ArcAttributes arcType -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ArcAttributes arcType] -> ShowS
$cshowList :: forall arcType. Show arcType => [ArcAttributes arcType] -> ShowS
show :: ArcAttributes arcType -> String
$cshow :: forall arcType. Show arcType => ArcAttributes arcType -> String
showsPrec :: Int -> ArcAttributes arcType -> ShowS
$cshowsPrec :: forall arcType.
Show arcType =>
Int -> ArcAttributes arcType -> ShowS
Show,Typeable)

data ArcPreAttributes = ArcPreAttributes {
   ArcPreAttributes -> String
preArcType :: String
   }

getArcAttributes :: (Registry String arcType) ->
   IO (Maybe (ArcAttributes arcType))
-- getArcAttributes gets the required attributes of an arc given
-- its possible types (with their titles).
getArcAttributes :: Registry String arcType -> IO (Maybe (ArcAttributes arcType))
getArcAttributes Registry String arcType
registry =
   IO (ArcAttributes arcType) -> IO (Maybe (ArcAttributes arcType))
forall a. IO a -> IO (Maybe a)
allowCancel (
      do
         [String]
knownTypeNames <- Registry String arcType -> IO [String]
forall registry from.
KeyOpsRegistry registry from =>
registry -> IO [from]
listKeys Registry String arcType
registry
         case [String]
knownTypeNames of
            [] ->
               do
                  String -> IO ()
displayError String
"You must first define some arc types"
                  IO ()
forall anything. IO anything
cancelQuery
            [String]
_ -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
         let
            def :: ArcPreAttributes
def = ArcPreAttributes :: String -> ArcPreAttributes
ArcPreAttributes {
               preArcType :: String
preArcType=[String] -> String
forall a. [a] -> a
head [String]
knownTypeNames
               }
         (InputWin ArcPreAttributes
iw, InputForm ArcPreAttributes
form) <- String
-> (Box -> IO (InputForm ArcPreAttributes))
-> [Config Toplevel]
-> IO (InputWin ArcPreAttributes, InputForm ArcPreAttributes)
forall a.
String
-> (Box -> IO (InputForm a))
-> [Config Toplevel]
-> IO (InputWin a, InputForm a)
createInputWin String
"Arc Attributes"
                                   (\Box
p-> Box
-> Maybe ArcPreAttributes
-> [Config (InputForm ArcPreAttributes)]
-> IO (InputForm ArcPreAttributes)
forall a.
Box -> Maybe a -> [Config (InputForm a)] -> IO (InputForm a)
newInputForm Box
p (ArcPreAttributes -> Maybe ArcPreAttributes
forall a. a -> Maybe a
Just ArcPreAttributes
def) []) []
         InputForm ArcPreAttributes
-> [String]
-> [Config (EnumField ArcPreAttributes String)]
-> IO (EnumField ArcPreAttributes String)
forall b a.
GUIValue b =>
InputForm a
-> [b] -> [Config (EnumField a b)] -> IO (EnumField a b)
newEnumField InputForm ArcPreAttributes
form [String]
knownTypeNames [
            -- text "Arc Type",
            (ArcPreAttributes -> String)
-> Config (EnumField ArcPreAttributes String)
forall (f :: * -> * -> *) b a.
(InputField f, GUIValue b) =>
(a -> b) -> Config (f a b)
selector ArcPreAttributes -> String
preArcType,
            (ArcPreAttributes -> String -> ArcPreAttributes)
-> Config (EnumField ArcPreAttributes String)
forall (f :: * -> * -> *) b a.
(InputField f, GUIValue b) =>
(a -> b -> a) -> Config (f a b)
modifier (\ ArcPreAttributes
old String
arcTypeName ->
               ArcPreAttributes
old {preArcType :: String
preArcType = String
arcTypeName})
            ]
         Maybe ArcPreAttributes
result <- InputWin ArcPreAttributes -> Bool -> IO (Maybe ArcPreAttributes)
forall a. InputWin a -> Bool -> IO (Maybe a)
wait InputWin ArcPreAttributes
iw Bool
True
         case Maybe ArcPreAttributes
result of
            Just (ArcPreAttributes {
               preArcType :: ArcPreAttributes -> String
preArcType = String
arcTypeName
               }) ->
                  do
                     arcType
arcType <- Registry String arcType -> String -> IO arcType
forall registry from to.
GetSetRegistry registry from to =>
registry -> from -> IO to
Registry.getValue Registry String arcType
registry String
arcTypeName
                     ArcAttributes arcType -> IO (ArcAttributes arcType)
forall (m :: * -> *) a. Monad m => a -> m a
return (ArcAttributes :: forall arcType. arcType -> ArcAttributes arcType
ArcAttributes {
                        arcType :: arcType
arcType = arcType
arcType
                        })
            Maybe ArcPreAttributes
Nothing -> IO (ArcAttributes arcType)
forall anything. IO anything
cancelQuery
      )

------------------------------------------------------------------------
-- General Routines
------------------------------------------------------------------------

displayError :: String -> IO ()
-- This displays an error message.
displayError :: String -> IO ()
displayError = String -> IO ()
errorMess

getSingleString :: String -> IO String
-- This gets a single string from the user, prompting with the argument
-- provided.
getSingleString :: String -> IO String
getSingleString String
query =
   do
      (InputWin String
inputWin, InputForm String
form) <- String
-> (Box -> IO (InputForm String))
-> [Config Toplevel]
-> IO (InputWin String, InputForm String)
forall a.
String
-> (Box -> IO (InputForm a))
-> [Config Toplevel]
-> IO (InputWin a, InputForm a)
createInputWin String
"" (\Box
p-> Box
-> Maybe String
-> [Config (InputForm String)]
-> IO (InputForm String)
forall a.
Box -> Maybe a -> [Config (InputForm a)] -> IO (InputForm a)
newInputForm Box
p (String -> Maybe String
forall a. a -> Maybe a
Just String
"") []) []
      (EntryField String String
entryField :: EntryField String String) <-
         InputForm String
-> [Config (EntryField String String)]
-> IO (EntryField String String)
forall b a.
GUIValue b =>
InputForm a -> [Config (EntryField a b)] -> IO (EntryField a b)
newEntryField InputForm String
form [
            String -> Config (EntryField String String)
forall w v. HasText w v => v -> Config w
text String
query,
            ShowS -> Config (EntryField String String)
forall (f :: * -> * -> *) b a.
(InputField f, GUIValue b) =>
(a -> b) -> Config (f a b)
selector ShowS
forall a. a -> a
id,
            (String -> ShowS) -> Config (EntryField String String)
forall (f :: * -> * -> *) b a.
(InputField f, GUIValue b) =>
(a -> b -> a) -> Config (f a b)
modifier (\ String
oldValue String
newValue -> String
newValue),
            Distance -> Config (EntryField String String)
forall w. HasSize w => Distance -> Config w
width Distance
20
            ]
      Maybe String
result <- InputWin String -> Bool -> IO (Maybe String)
forall a. InputWin a -> Bool -> IO (Maybe a)
wait InputWin String
inputWin Bool
True
      case Maybe String
result of
         Just String
value -> String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return String
value
         Maybe String
Nothing -> IO String
forall anything. IO anything
cancelQuery

newtype CancelException = CancelException () deriving (Typeable)

cancelQuery :: IO anything
cancelQuery :: IO anything
cancelQuery = Dyn -> IO anything
forall a e. Exception e => e -> a
throw (Dyn -> IO anything) -> Dyn -> IO anything
forall a b. (a -> b) -> a -> b
$ CancelException -> Dyn
forall a. Typeable a => a -> Dyn
toDyn (() -> CancelException
CancelException ())

allowCancel :: IO a -> IO (Maybe a)
allowCancel :: IO a -> IO (Maybe a)
allowCancel IO a
action =
   (Dyn -> Maybe (Maybe ()))
-> IO (Maybe a) -> (Maybe () -> IO (Maybe a)) -> IO (Maybe a)
forall e b a.
Exception e =>
(e -> Maybe b) -> IO a -> (b -> IO a) -> IO a
Exception.catchJust
      (\ Dyn
e -> case Dyn -> Maybe CancelException
forall a. Typeable a => Dyn -> Maybe a
fromDynamic Dyn
e of
           Just (CancelException ()) -> Maybe () -> Maybe (Maybe ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe () -> Maybe (Maybe ())) -> Maybe () -> Maybe (Maybe ())
forall a b. (a -> b) -> a -> b
$ () -> Maybe ()
forall a. a -> Maybe a
Just ()
           Maybe CancelException
_ -> Maybe () -> Maybe (Maybe ())
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ()
forall a. Maybe a
Nothing)
      (do
         a
result <- IO a
action
         Maybe a -> IO (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> Maybe a
forall a. a -> Maybe a
Just a
result)
         )
      (\ Maybe ()
_ -> Maybe a -> IO (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing)