{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE DeriveDataTypeable #-}
module Graphs.GetAttributes(
NodeTypeAttributes(..),
getNodeTypeAttributes,
NodeAttributes(..),
getNodeAttributes,
ArcTypeAttributes(..),
getArcTypeAttributes,
ArcAttributes(..),
getArcAttributes,
displayError,
) 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
data ShapeSort = Box | Circle | Ellipse | Rhombus | Triangle | Icon
deriving (Enum,Read,Show)
instance GUIValue ShapeSort where
cdefault = Box
data NodeTypeAttributes nodeLabel = NodeTypeAttributes {
shape :: GraphConfigure.Shape nodeLabel,
nodeTypeTitle :: String
} deriving (Read,Show,Typeable)
data PreAttributes = PreAttributes {
shapeSort :: ShapeSort,
nodeTypeTitle' :: String
}
getNodeTypeAttributes :: IO (Maybe(NodeTypeAttributes nodeLabel))
getNodeTypeAttributes =
allowCancel (
do
PreAttributes {shapeSort=shapeSort,nodeTypeTitle'=nodeTypeTitle} <-
getNodeTypeAttributes1
shape <- case shapeSort of
Box -> return GraphConfigure.Box
Circle -> return GraphConfigure.Circle
Ellipse -> return GraphConfigure.Ellipse
Rhombus -> return GraphConfigure.Rhombus
Triangle -> return GraphConfigure.Triangle
Icon ->
do
fname <- getSingleString "Icon filename"
return (GraphConfigure.Icon fname)
return NodeTypeAttributes {shape=shape,nodeTypeTitle=nodeTypeTitle} )
getNodeTypeAttributes1 :: IO PreAttributes
getNodeTypeAttributes1 =
do
let def = PreAttributes {shapeSort=Box,nodeTypeTitle'=""}
(iw, form) <- createInputWin "Node Type Attributes"
(\p-> newInputForm p (Just def) []) []
newEnumField form [Box .. Icon] [
selector shapeSort,
modifier (\ old newShape -> old {shapeSort = newShape})
]
newEntryField form [
text "Node Type title",
selector nodeTypeTitle',
modifier (\ old newTitle -> old {nodeTypeTitle' = newTitle}),
width 20
]
result <- wait iw True
case result of
Just value -> return value
Nothing -> cancelQuery
data NodeAttributes nodeType = NodeAttributes {
nodeType :: nodeType,
nodeTitle :: String
} deriving (Read,Show,Typeable)
data NodePreAttributes = NodePreAttributes {
preNodeType :: String,
preNodeTitle :: String
} deriving Show
getNodeAttributes :: (Registry String nodeType) ->
IO (Maybe (NodeAttributes nodeType))
getNodeAttributes registry =
allowCancel (
do
knownTypeNames <- listKeys registry
case knownTypeNames of
[] ->
do
displayError "You must first define some node types"
cancelQuery
_ -> return ()
let
def = NodePreAttributes {
preNodeType=head knownTypeNames,
preNodeTitle=""
}
(inputWin, form) <- createInputWin "Node Attributes"
(\p-> newInputForm p (Just def) []) []
newEnumField form knownTypeNames [
selector preNodeType,
modifier (\ old nodeTypeName ->
old {preNodeType = nodeTypeName})
]
newEntryField form [
text "Node title",
selector preNodeTitle,
modifier (\ old newTitle -> old {preNodeTitle = newTitle}),
width 20
]
result <- wait inputWin True
case result of
Just (NodePreAttributes {
preNodeTitle = nodeTitle,
preNodeType = nodeTypeName
}) ->
do
nodeType <- Registry.getValue registry nodeTypeName
return (NodeAttributes {
nodeTitle = nodeTitle,
nodeType = nodeType
})
Nothing -> cancelQuery
)
data ArcTypeAttributes = ArcTypeAttributes {
arcTypeTitle :: String
} deriving (Read,Show,Typeable)
getArcTypeAttributes :: IO (Maybe ArcTypeAttributes)
getArcTypeAttributes =
do
let def = ArcTypeAttributes {arcTypeTitle=""}
(iw, form) <- createInputWin "Arc Type Attributes"
(\p-> newInputForm p (Just def) []) []
newEntryField form [
text "Arc Type title",
selector arcTypeTitle,
modifier (\ old newTitle -> old {arcTypeTitle = newTitle}),
width 20
]
wait iw True
data ArcAttributes arcType = ArcAttributes {
arcType :: arcType
} deriving (Read,Show,Typeable)
data ArcPreAttributes = ArcPreAttributes {
preArcType :: String
}
getArcAttributes :: (Registry String arcType) ->
IO (Maybe (ArcAttributes arcType))
getArcAttributes registry =
allowCancel (
do
knownTypeNames <- listKeys registry
case knownTypeNames of
[] ->
do
displayError "You must first define some arc types"
cancelQuery
_ -> return ()
let
def = ArcPreAttributes {
preArcType=head knownTypeNames
}
(iw, form) <- createInputWin "Arc Attributes"
(\p-> newInputForm p (Just def) []) []
newEnumField form knownTypeNames [
selector preArcType,
modifier (\ old arcTypeName ->
old {preArcType = arcTypeName})
]
result <- wait iw True
case result of
Just (ArcPreAttributes {
preArcType = arcTypeName
}) ->
do
arcType <- Registry.getValue registry arcTypeName
return (ArcAttributes {
arcType = arcType
})
Nothing -> cancelQuery
)
displayError :: String -> IO ()
displayError = errorMess
getSingleString :: String -> IO String
getSingleString query =
do
(inputWin, form) <- createInputWin "" (\p-> newInputForm p (Just "") []) []
(entryField :: EntryField String String) <-
newEntryField form [
text query,
selector id,
modifier (\ oldValue newValue -> newValue),
width 20
]
result <- wait inputWin True
case result of
Just value -> return value
Nothing -> cancelQuery
newtype CancelException = CancelException () deriving (Typeable)
cancelQuery :: IO anything
cancelQuery = throw $ toDyn (CancelException ())
allowCancel :: IO a -> IO (Maybe a)
allowCancel action =
Exception.catchJust
(\ e -> case fromDynamic e of
Just (CancelException ()) -> return $ Just ()
_ -> return Nothing)
(do
result <- action
return (Just result)
)
(\ _ -> return Nothing)