repos / INblobs / headblob
summary | shortlog | log | tree | annotate | headblob | filehistory
plain
/ src /
src/NetworkFile.hs
1 {-# OPTIONS -fallow-undecidable-instances #-}
2
3 module NetworkFile where
4
5 import Network
6 import Math
7 import Common
8 import Colors
9 import Shape
10 import InfoKind
11 import Ports
12
13 import Text.XML.HaXml.Types
14 import Text.XML.HaXml.Escape
15 import Text.XML.HaXml.Posn (noPos)
16 import Text.XML.HaXml.Parse
17 import Text.XML.HaXml.XmlContent as XML
18 import Text.XML.HaXml.Combinators (replaceAttrs)
19 import Text.XML.HaXml.Verbatim
20 import Text.PrettyPrint.HughesPJ
21 import qualified Text.XML.HaXml.Pretty as Pretty
22 import Data.Char
23 import Data.Maybe
24 import Monad(when)
25 import Data.List(nub,isPrefixOf)
26
27 -- | Print the network data structure to an XML text
28 toString :: (InfoKind n g, InfoKind e g, XmlContent g) =>
29 Network g n e -> String
30 toString network = render . Pretty.document $
31 Document (Prolog Nothing [] Nothing []) emptyST (f (toContents network)) []
32 where
33 f [CElem e _] = e
34 f _ = error "bad" -- shouldn't happen
35
36 -- | Parses a string to the network data structure
37 -- Returns either an error message (Left) or the network,
38 -- a list of warnings (Right) and a boolean indicating whether
39 -- the file was an old Dazzle file
40 fromString :: (InfoKind n g, InfoKind e g, XmlContent g) =>
41 String -> Either String (Network g n e, [String], Bool)
42 fromString xml =
43 case xmlParse' "input file" xml of
44 Left err -> Left err -- lexical or initial (generic) parse error
45 Right (Document _ _ e _) ->
46 case runParser parseContents [CElem e noPos] of
47 (Left err, _) -> Left err -- secondary (typeful) parse error
48 (Right v, _) -> Right (v,[],False)
49
50 {-
51 -- non-XML output
52 toStringShow :: (Show g, Show n, Show e) => Network g n e -> String
53 toStringShow network =
54 show ( getNodeAssocs network
55 , getEdgeAssocs network
56 , getCanvasSize network
57 , getGlobalInfo network
58 )
59
60 fromStringShow :: (Read g, InfoKind n g, InfoKind e g) =>
61 String -> Either String (Network g n e)
62 fromStringShow txt =
63 case reads txt of
64 ((tuple,[]):_) ->
65 let (nodeAssocs, edgeAssocs, canvasSize, globalInfo) = tuple
66 in Right ( setNodeAssocs nodeAssocs
67 . setEdgeAssocs edgeAssocs
68 . setCanvasSize canvasSize
69 $ Network.empty globalInfo undefined undefined
70 )
71 _ -> Left "File is not a " ++ toolName ++ " network"
72 -}
73
74 ---------------------------------------------------------
75 -- Internal type isomorphic to (index,value) pairs
76 -- (but permits instances of classes)
77 ---------------------------------------------------------
78 data AssocN n = AssocN Int (Node n)
79 deAssocN :: AssocN n -> (Int,Node n)
80 deAssocN (AssocN n v) = (n,v)
81 data AssocE e = AssocE Int (Edge e)
82 deAssocE :: AssocE e -> (Int,Edge e)
83 deAssocE (AssocE n v) = (n,v)
84
85 ---------------------------------------------------------
86 -- Convert our data type to/from an XML tree
87 ---------------------------------------------------------
88 instance HTypeable (Network g n e) where
89 toHType _ = Defined "Network" [] [Constr "Network" [] []]
90 instance (InfoKind n g, InfoKind e g, XmlContent g) =>
91 XmlContent (Network g n e) where
92 toContents network =
93 [CElem (Elem "Network"
94 [ mkAttr "Width" (show width)
95 , mkAttr "Height" (show height)
96 ]
97 [ makeTag "Info" (toContents netInfo)
98 , makeTag "Nodes" (concatMap toContents nodeAssocs)
99 , makeTag "Edges" (concatMap toContents edgeAssocs)
100 ]) () ]
101 where
102 nodeAssocs = map (uncurry AssocN) $ getNodeAssocs network
103 edgeAssocs = map (uncurry AssocE) $ getEdgeAssocs network
104 (width, height) = getCanvasSize network
105 netInfo = getGlobalInfo network
106 parseContents = do
107 { (p, e@(Elem _ [("Width",w),("Height",h)] cs)) <- posnElement ["Network"]
108 ; reparse cs
109 ; w' <- attr2value w
110 ; h' <- attr2value h
111 ; i <- inElement "Info" $ parseContents
112 ; ns <- inElement "Nodes" $ many parseContents
113 ; es <- inElement "Edges" $ many parseContents
114 ; networkValid ns es
115 ; return ( setCanvasSize (w',h')
116 . setNodeAssocs (map deAssocN ns)
117 . setEdgeAssocs (map deAssocE es)
118 $ Network.empty i undefined undefined)
119 }
120
121 attr2value :: (Read a) => AttValue -> XMLParser a
122 attr2value (AttValue [Left n]) = return (read n)
123 attr2value (AttValue s) = fail ("Problem reading Node ID: "++verbatim s)
124
125 peekAttributes :: String -> XMLParser [(String,AttValue)]
126 peekAttributes t =
127 do{ (p, e@(Elem _ as _)) <- posnElement [t]
128 ; reparse [CElem e p]
129 ; return as
130 }
131
132 instance HTypeable (AssocN n) where
133 toHType _ = Defined "Node" [] [Constr "Node" [] []]
134 instance (InfoKind n g) => XmlContent (AssocN n) where
135 toContents (AssocN n node) =
136 concatMap (replaceAttrs [("id",'N':show n)]) (toContents node)
137 parseContents = do
138 { [("id",n)] <- peekAttributes "Node"
139 ; n' <- num n
140 ; node <- parseContents
141 ; return (AssocN n' node)
142 }
143 where num (AttValue [Left ('N':n)]) = return (read n)
144 num (AttValue s) = fail ("Problem reading Node ID: "++verbatim s)
145
146 instance HTypeable (AssocE e) where
147 toHType _ = Defined "Edge" [] [Constr "Edge" [] []]
148 instance (InfoKind e g) => XmlContent (AssocE e) where
149 toContents (AssocE n edge) =
150 concatMap (replaceAttrs [("id",'E':show n)]) (toContents edge)
151 parseContents = do
152 { [("id",n)] <- peekAttributes "Edge"
153 ; n' <- num n
154 ; edge <- parseContents
155 ; return (AssocE n' edge)
156 }
157 where num (AttValue [Left ('E':n)]) = return (read n)
158 num (AttValue s) = fail ("Problem reading Edge ID: "++verbatim s)
159
160 instance HTypeable (Node n) where
161 toHType _ = Defined "Node" [] [Constr "Node" [] []]
162 instance (InfoKind n g) => XmlContent (Node n) where
163 toContents node =
164 [ makeTag "Node"
165 (toContents (getPosition node) ++
166 [ escapeString "Name" (getName node)
167 , simpleString "LabelAbove" (show (getNameAbove node))
168 , escapeString "Shape" (getShape node)
169 , makeTag "Info" (toContents (getInfo node))
170 ])
171 ]
172 parseContents = do
173 { inElement "Node" $ do
174 { p <- parseContents -- position
175 ; n <- inElement "Name" $ XML.text
176 ; a <- inElement "LabelAbove" $ fmap read XML.text
177 ; s <- inElement "Shape" $ XML.text
178 ; i <- inElement "Info" $ parseContents
179 ; return (constructNode n p a s i)
180 }
181 }
182
183 instance HTypeable DoublePoint where
184 toHType _ = Defined "DoublePoint" [] [Constr "X" [] [], Constr "Y" [] []]
185 instance XmlContent DoublePoint where
186 toContents (DoublePoint x y) =
187 [ CElem (Elem "Position"
188 [ mkAttr "X" (show x)
189 , mkAttr "Y" (show y)
190 ] []) () ]
191 parseContents = do
192 { (p, e@(Elem _ [("X",x),("Y",y)] [])) <- posnElement ["Position"]
193 ; x' <- attr2value x
194 ; y' <- attr2value y
195 ; return (DoublePoint x' y')
196 }
197
198 instance HTypeable (Edge e) where
199 toHType _ = Defined "Edge" [] [Constr "Edge" [] []]
200 instance InfoKind e g => XmlContent (Edge e) where
201 toContents edge =
202 [ makeTag "Edge"
203 [ simpleString "From" (show (getEdgeFrom edge))
204 , escapeString "PortFrom" (getPortFrom edge)
205 , simpleString "To" (show (getEdgeTo edge))
206 , escapeString "PortTo" (getPortTo edge)
207 , makeTag "Via" (concatMap toContents (getEdgeVia edge))
208 , makeTag "Info" (toContents (getEdgeInfo edge))
209 ]
210 ]
211 where maybeSnd = maybe Nothing (Just . snd)
212 parseContents = do
213 { inElement "Edge" $ do
214 { f <- inElement "From" $ fmap read XML.text
215 ; q <- inElement "PortFrom" $ XML.text
216 ; t <- inElement "To" $ fmap read XML.text
217 ; r <- inElement "PortTo" $ XML.text
218 ; v <- inElement "Via" $ many parseContents
219 ; i <- inElement "Info" $ parseContents
220 ; return (constructEdge f q t r v i)
221 }
222 }
223
224 instance HTypeable Colour where
225 toHType v = Defined "Colour" []
226 [Constr "RGB" [] [toHType aa,toHType ab,toHType ac]]
227 where (RGB aa ab ac) = v
228 instance XmlContent Colour where
229 parseContents = do
230 { (p, e@(Elem _ [("R",r),("G",g),("B",b)] [])) <- posnElement ["RGB"]
231 ; r' <- attr2value r
232 ; g' <- attr2value g
233 ; b' <- attr2value b
234 ; return (RGB r' g' b')
235 }
236 toContents v@(RGB aa ab ac) =
237 [CElem (Elem (showConstr 0 (toHType v))
238 [ mkAttr "R" (show aa)
239 , mkAttr "G" (show ab)
240 , mkAttr "B" (show ac)
241 ] []) () ]
242
243 {- derived by DrIFT -}
244 instance HTypeable Shape where
245 toHType v =
246 Defined "Shape" []
247 [Constr "Circle" [] [toHType aa,toHType ab],
248 Constr "Polygon" [] [toHType ac,toHType ad],
249 Constr "Lines" [] [toHType ae,toHType af],
250 Constr "Points" [] [toHType ag,toHType ah],
251 Constr "Rectangle" [] [toHType ai,toHType aj,toHType ak],
252 Constr "Arc" []
253 [toHType al,toHType am,toHType an,toHType ao,toHType ap]
254 ,Constr "Ellipse" [] [toHType aq,toHType ar,toHType as,toHType at],
255 Constr "EllipticArc" []
256 [toHType au,toHType av,toHType aw,toHType ax,toHType ay,toHType az]
257 ,Constr "RoundRec" [] [toHType aA,toHType aB,toHType aC,toHType aD]
258 ,Constr "Text" [] [toHType aE,toHType aF],
259 Constr "Composite" [] [toHType aG],
260 Constr "TextInEllipse" [] [toHType aH,toHType aI]]
261 where
262 (Circle aa ab) = v
263 (Polygon ac ad) = v
264 (Lines ae af) = v
265 (Points ag ah) = v
266 (Rectangle ai aj ak) = v
267 (Arc al am an ao ap) = v
268 (Ellipse aq ar as at) = v
269 (EllipticArc au av aw ax ay az) = v
270 (RoundRec aA aB aC aD) = v
271 (Text aE aF) = v
272 (Composite aG) = v
273 (TextInEllipse aH aI) = v
274
275 instance XmlContent Shape where
276 parseContents = do
277 { e@(Elem t _ _) <- elementWith (flip isPrefixOf) ["TextInEllipse","Text","RoundRec","Rectangle","Polygon","Points","Lines","EllipticArc","Ellipse","Composite","Circle","Arc"]
278 ; case t of
279 _ | "TextInEllipse" `isPrefixOf` t -> interior e $
280 return TextInEllipse `apply` parseContents `apply` parseContents
281 | "Text" `isPrefixOf` t -> interior e $
282 return Text `apply` parseContents `apply` parseContents
283 | "RoundRec" `isPrefixOf` t -> interior e $
284 return RoundRec `apply` parseContents `apply` parseContents
285 `apply` parseContents `apply` parseContents
286 | "Rectangle" `isPrefixOf` t -> interior e $
287 return Rectangle `apply` parseContents `apply` parseContents
288 `apply` parseContents
289 | "Polygon" `isPrefixOf` t -> interior e $
290 return Polygon `apply` parseContents `apply` parseContents
291 | "Points" `isPrefixOf` t -> interior e $
292 return Points `apply` parseContents `apply` parseContents
293 | "Lines" `isPrefixOf` t -> interior e $
294 return Lines `apply` parseContents `apply` parseContents
295 | "EllipticArc" `isPrefixOf` t -> interior e $
296 return EllipticArc `apply` parseContents `apply` parseContents
297 `apply` parseContents `apply` parseContents
298 `apply` parseContents `apply` parseContents
299 | "Ellipse" `isPrefixOf` t -> interior e $
300 return Ellipse `apply` parseContents `apply` parseContents
301 `apply` parseContents `apply` parseContents
302 | "Composite" `isPrefixOf` t -> interior e $ fmap Composite parseContents
303 | "Circle" `isPrefixOf` t -> interior e $
304 return Circle `apply` parseContents `apply` parseContents
305 | "Arc" `isPrefixOf` t -> interior e $
306 return Arc `apply` parseContents `apply` parseContents
307 `apply` parseContents `apply` parseContents `apply` parseContents
308 }
309 toContents v@(Circle aa ab) =
310 [mkElemC (showConstr 0 (toHType v)) (concat [toContents aa,
311 toContents ab])]
312 toContents v@(Polygon ac ad) =
313 [mkElemC (showConstr 1 (toHType v)) (concat [toContents ac,
314 toContents ad])]
315 toContents v@(Lines ae af) =
316 [mkElemC (showConstr 2 (toHType v)) (concat [toContents ae,
317 toContents af])]
318 toContents v@(Points ag ah) =
319 [mkElemC (showConstr 3 (toHType v)) (concat [toContents ag,
320 toContents ah])]
321 toContents v@(Rectangle ai aj ak) =
322 [mkElemC (showConstr 4 (toHType v)) (concat [toContents ai,
323 toContents aj,toContents ak])]
324 toContents v@(Arc al am an ao ap) =
325 [mkElemC (showConstr 5 (toHType v)) (concat [toContents al,
326 toContents am,toContents an,toContents ao,
327 toContents ap])]
328 toContents v@(Ellipse aq ar as at) =
329 [mkElemC (showConstr 6 (toHType v)) (concat [toContents aq,
330 toContents ar,toContents as,toContents at])]
331 toContents v@(EllipticArc au av aw ax ay az) =
332 [mkElemC (showConstr 7 (toHType v)) (concat [toContents au,
333 toContents av,toContents aw,toContents ax,
334 toContents ay,toContents az])]
335 toContents v@(RoundRec aA aB aC aD) =
336 [mkElemC (showConstr 8 (toHType v)) (concat [toContents aA,
337 toContents aB,toContents aC,toContents aD])]
338 toContents v@(Text aE aF) =
339 [mkElemC (showConstr 9 (toHType v)) (concat [toContents aE,
340 toContents aF])]
341 toContents v@(Composite aG) =
342 [mkElemC (showConstr 10 (toHType v)) (toContents aG)]
343 toContents v@(TextInEllipse aH aI) =
344 [mkElemC (showConstr 11 (toHType v)) (concat [toContents aH,
345 toContents aI])]
346
347 {- derived by DrIFT -}
348 instance HTypeable ShapeStyle where
349 toHType v = Defined "ShapeStyle" []
350 [Constr "ShapeStyle" [] [toHType aa,toHType ab,toHType ac]]
351 where (ShapeStyle aa ab ac) = v
352 instance XmlContent ShapeStyle where
353 parseContents = do
354 { inElement "ShapeStyle" $ do
355 { aa <- parseContents
356 ; ab <- parseContents
357 ; ac <- parseContents
358 ; return (ShapeStyle aa ab ac)
359 }
360 }
361 toContents v@(ShapeStyle aa ab ac) =
362 [mkElemC (showConstr 0 (toHType v))
363 (concat [toContents aa, toContents ab, toContents ac])]
364
365
366 ---- UTILITY FUNCTIONS
367
368 -- Abbreviations
369 makeTag :: String -> [Content i] -> Content i
370 makeTag name children = CElem (Elem name [] children) undefined
371
372 tagWithId :: String -> String -> [Content i] -> Content i
373 tagWithId name identity children =
374 CElem (Elem name [("id", AttValue [Left identity])] children) undefined
375
376 -- | A simple string contains no spaces or unsafe characters
377 simpleString :: String -> String -> Content i
378 simpleString tag value =
379 CElem (Elem tag [] [ CString False value undefined ]) undefined
380
381 -- | The string value may contain spaces and unsafe characters
382 escapeString :: String -> String -> Content i
383 escapeString key value =
384 CElem (Elem key [] [ CString True value undefined ]) undefined
385
386 comment :: String -> Content i
387 comment s = CMisc (Comment (commentEscape s)) undefined
388
389 -- Replace occurences of "-->" with "==>" in a string so that the string
390 -- becomes safe for an XML comment
391 commentEscape :: String -> String
392 commentEscape [] = []
393 commentEscape ('-':'-':'>':xs) = "==>" ++ commentEscape xs
394 commentEscape (x:xs) = x : commentEscape xs
395
396 ---------------------------------------------------------
397 -- Check whether the network read from file is valid
398 ---------------------------------------------------------
399
400 networkValid :: [AssocN n] -> [AssocE e] -> XMLParser ()
401 networkValid nodeAssocs edgeAssocs
402 | containsDuplicates nodeNrs =
403 fail "Node numbers should be unique"
404 | containsDuplicates edgeNrs =
405 fail "Edge numbers should be unique"
406 | otherwise =
407 do{ mapM_ (checkEdge nodeNrs) edgeAssocs
408 ; -- determine whether there are multiple edges between any two nodes
409 ; let multipleEdges = duplicatesBy betweenSameNodes edges
410 ; when (not (null multipleEdges)) $
411 fail $ "There are multiple edges between the following node pairs: " ++
412 commasAnd [ "(" ++ show (getEdgeFrom e) ++ ", "
413 ++ show (getEdgeTo e) ++ ")"
414 | e <- multipleEdges
415 ]
416 ; return ()
417 }
418 where
419 nodeNrs = map (fst . deAssocN) nodeAssocs
420 (edgeNrs, edges) = unzip (map deAssocE edgeAssocs)
421
422 -- Check whether edges refer to existing node numbers and whether
423 -- there are no edges that start and end in the same pair (node, port)
424 checkEdge :: [NodeNr] -> AssocE e -> XMLParser ()
425 checkEdge nodeNrs (AssocE edgeNr edge)
426 | (fromNr, fromPort) == (toNr, toPort) =
427 fail $ "Edge " ++ show edgeNr ++ ": from-node and to-node are the same"
428 | fromNr `notElem` nodeNrs = nonExistingNode fromNr
429 | toNr `notElem` nodeNrs = nonExistingNode toNr
430 | otherwise = return ()
431 where
432 fromNr = getEdgeFrom edge
433 fromPort = getPortFrom edge
434 toNr = getEdgeTo edge
435 toPort = getPortTo edge
436 nonExistingNode nodeNr =
437 fail $ "Edge " ++ show edgeNr ++ ": refers to non-existing node "
438 ++ show nodeNr
439
440 containsDuplicates :: Eq a => [a] -> Bool
441 containsDuplicates xs = length (nub xs) /= length xs
442
443 -- Partial equality on edges
444 betweenSameNodes :: Edge e -> Edge e -> Bool
445 betweenSameNodes e1 e2 =
446 ( getEdgeFrom e1 == getEdgeFrom e2 && getEdgeTo e1 == getEdgeTo e2
447 && getPortFrom e1 == getPortFrom e2 && getPortTo e1 == getPortTo e2 )
448 ||
449 ( getEdgeFrom e1 == getEdgeTo e2 && getEdgeTo e1 == getEdgeFrom e1
450 && getPortFrom e1 == getPortTo e2 && getPortTo e1 == getPortFrom e2 )
451
452 -- Returns elements that appear more than once in a list
453 duplicates :: Eq a => [a] -> [a]
454 duplicates [] = []
455 duplicates (x:xs)
456 | x `elem` xs = x : duplicates (filter (/= x) xs)
457 | otherwise = duplicates xs
458
459 -- Returns elements that appear more than once in a list, using given Eq op
460 duplicatesBy :: (a->a->Bool) -> [a] -> [a]
461 duplicatesBy _ [] = []
462 duplicatesBy eq (x:xs)
463 | any (eq x) xs = x : duplicatesBy eq (filter (not . eq x) xs)
464 | otherwise = duplicatesBy eq xs
465
Crece desde el pueblo el futuro / crece desde el pie