darcs - INblobs

1 {-| Module : Document

2 Maintainer : afie@cs.uu.nl

4 This module contains functions to create documents

5 and to get and set components of the Document datatype.

6 -}

8 module Document

9 ( Document

10 , RuleName

11 , ActiveCanvas(..)

12 , Selection(..)

13 , empty

14 , getNetwork, setNetwork, unsafeSetNetwork

15 , getPalette, setPalette

16 , getSelection, setSelection

17 , getRules, setRules

19 , updateNetwork, updateNetworkEx

20 , joinPalette

21 , updateRules

22 , selectNetwork

23 , updateSelNetwork, updateSelNetworkEx

24 , removeMappingElemWithNode

25 , show'

26 ) where

28 import Network hiding (empty)

29 import INRule

30 import INRules hiding (empty)

31 import InfoKind

32 import Math

33 import Ports

34 import Palette hiding (delete, empty)

35 import qualified Network (empty)

36 import qualified INRules (empty)

37 import qualified Palette (empty)

39 import Data.Maybe

41 {--------------------------------------------------

42 -- TYPES

43 --------------------------------------------------}

45 data Document g n e = Document

46 { docNetwork :: Network g n e

47 , docPalette :: Palette n -- ^ the current 'Palette'

48 , docSelection :: Selection

49 , docRules :: INRules g n e

50 } deriving Show

52 type RuleName = String

53 data ActiveCanvas = Net | LHS RuleName | RHS RuleName deriving (Show, Eq, Read)

55 data Selection

56 = NoSelection

57 | NodeSelection ActiveCanvas Int (Maybe PortName)

58 | EdgeSelection ActiveCanvas Int

59 | ViaSelection ActiveCanvas Int Int

60 | MultipleSelection ActiveCanvas

61 (Maybe (DoublePoint,DoublePoint)) [Int] [(Int,Int)]

62 -- DoublePoint pair is for displaying dragged selection rectangle

63 deriving (Show, Read, Eq)

65 {--------------------------------------------------

66 -- CREATION

67 --------------------------------------------------}

70 -- | An empty document

71 empty :: (InfoKind e g, InfoKind n g) => g -> n -> e -> Document g n e

72 empty g n e =

73 Document

74 { docNetwork = Network.empty g n e

75 , docPalette = Palette.empty

76 , docSelection = NoSelection

77 , docRules = INRules.empty g n e

78 }

80 {--------------------------------------------------

81 -- GETTERS

82 --------------------------------------------------}

84 getNetwork :: Document g n e -> Network g n e

85 getPalette :: Document g n e -> Palette n

86 getSelection :: Document g n e -> Selection

87 getRules :: Document g n e -> INRules g n e

89 getNetwork doc = docNetwork doc

90 getPalette doc = docPalette doc

91 getSelection doc = docSelection doc

92 getRules doc = docRules doc

94 {--------------------------------------------------

95 -- SETTERS

96 --------------------------------------------------}

98 -- | setNetwork clears the selection because the node may not exist

99 -- in the new network

100 setNetwork :: Network g n e -> Document g n e -> Document g n e

101 setNetwork theNetwork doc =

102 doc { docNetwork = theNetwork

103 , docSelection = NoSelection

104 }

105

106 setPalette :: Palette n -> Document g n e -> Document g n e

107 setPalette thePalette doc = doc { docPalette = thePalette }

108

109 setSelection :: Selection -> Document g n e -> Document g n e

110 setSelection theSelection doc = doc { docSelection = theSelection }

111

112 setRules :: INRules g n e -> Document g n e -> Document g n e

113 setRules theRules doc = doc {docRules = theRules}

114

115 updateNetwork :: (Network g n e -> Network g n e)

116 -> Document g n e -> Document g n e

117 updateNetwork networkFun doc

118 = unsafeSetNetwork (networkFun (getNetwork doc))

119 $ doc

120

121 updateNetworkEx :: (Network g n e -> (b, Network g n e))

122 -> Document g n e -> (b, Document g n e)

123 updateNetworkEx networkFun doc =

124 let (result, newNetwork) = networkFun (getNetwork doc)

125 in ( result

126 , unsafeSetNetwork newNetwork doc

127 )

128

129 joinPalette :: (Eq n) => Palette n -> Document g n e -> Document g n e

130 joinPalette palette doc = doc { docPalette = join (getPalette doc) palette }

131

132 updateRules :: (INRules g n e -> INRules g n e)

133 -> Document g n e -> Document g n e

134 updateRules rulesFun doc = doc { docRules = rulesFun $ docRules doc }

135

136 -- | Doesn't clear the selection

137 unsafeSetNetwork :: Network g n e -> Document g n e -> Document g n e

138 unsafeSetNetwork theNetwork doc = doc { docNetwork = theNetwork }

139

140 -- | Given a document and the active canvas this function selects

141 -- the corresponding network.

142 selectNetwork :: Document g n e -> ActiveCanvas -> Network g n e

143 selectNetwork doc canvas =

144 case canvas of

145 Net -> getNetwork doc

146 LHS ruleName -> fromMaybe (erro ruleName)

147 $ getLHS `fromRule` ruleName $ getRules doc

148 RHS ruleName -> fromMaybe (erro ruleName)

149 $ getRHS `fromRule` ruleName $ getRules doc

150 where erro ruleName = error $ "This shouldn't happen because << "

151 ++ ruleName ++ " >> must be a rule."

152

153 -- | Given a document and the active canvas this function updates

154 -- the corresponding network accordingly the the updater network

155 -- function given as an argument.

156 updateSelNetwork :: (Network g n e -> Network g n e)

157 -> ActiveCanvas -> Document g n e -> Document g n e

158 updateSelNetwork netFunc canvas doc =

159 case canvas of

160 Net -> updateNetwork netFunc doc

161 LHS ruleName -> updateRules (updateRule ruleName $ updateLHS netFunc) doc

162 RHS ruleName -> updateRules (updateRule ruleName $ updateRHS netFunc) doc

163

164 updateSelNetworkEx :: (Network g n e -> (b, Network g n e))

165 -> ActiveCanvas -> Document g n e -> (b, Document g n e)

166 updateSelNetworkEx networkFun canvas doc =

167 let (result, newNetwork) = networkFun (selectNetwork doc canvas)

168 in ( result

169 , case canvas of

170 Net -> unsafeSetNetwork newNetwork doc

171 LHS ruleName -> updateRules (updateRule ruleName

172 $ setLHS newNetwork) doc

173 RHS ruleName -> updateRules (updateRule ruleName

174 $ setRHS newNetwork) doc

175 )

176

177 removeMappingElemWithNode :: ActiveCanvas -> NodeNr -> Document g n e -> Document g n e

178 removeMappingElemWithNode canv nodeNr =

179 case canv of

180 Net -> id

181 LHS rule -> updateRules $ updateRule rule $ updateMapping $ filter $ (/= nodeNr) . fst

182 RHS rule -> updateRules $ updateRule rule $ updateMapping $ filter $ (/= nodeNr) . snd

183

184 show' :: ActiveCanvas -> String

185 show' Net = "net"

186 show' (LHS rule) = "rule " ++ rule ++ "'s LHS"

187 show' (RHS rule) = "rule " ++ rule ++ "'s RHS"