Tue Sep 27 15:40:54 WEST 2005 Malcolm.Wallace@cs.york.ac.uk
* rejig XML writer/parser
Originally, this module used home-grown (in Utrecht) conversion functions
from values to XML and back, with better errors and warnings than HaXml
provided. Now that the Haskell2XmlNew part of HaXml has been improved,
we can get much of the error/warning stuff for free now, plus it is all
managed through a single class.
{
hunk ./src/NetworkFile.hs 7
+import Colors
+import Shape
+import InfoKind
hunk ./src/NetworkFile.hs 13
+import Text.XML.HaXml.Lex (noPos)
hunk ./src/NetworkFile.hs 15
+import Text.XML.HaXml.Haskell2XmlNew as XML
+import Text.XML.HaXml.Combinators (replaceAttrs)
+import Text.XML.HaXml.Verbatim
hunk ./src/NetworkFile.hs 25
--- | Print the network data structure to a text
-toString :: Network String -> String
-toString = toStringXML
+-- | Print the network data structure to an XML text
+toString :: InfoKind a => Network a -> String
+toString network = render . Pretty.document $
+ Document (Prolog Nothing [] Nothing []) emptyST (f (toContents network)) []
+ where
+ f [CElem e _] = e
hunk ./src/NetworkFile.hs 36
-fromString :: String -> Either String (Network String, [String], Bool)
-
--- xml file format
+fromString :: InfoKind a => String -> Either String (Network a, [String], Bool)
hunk ./src/NetworkFile.hs 38
- case fromStringXML xml of
- Left s -> Left s
- Right (networkComponents@(nodeAssocs, edgeAssocs, canvasSize), warnings) ->
- case runMM (networkValid networkComponents) of
- Left s -> Left s
- Right _ ->
- let network =
- ( setNodeAssocs nodeAssocs
- . setEdgeAssocs edgeAssocs
- . setCanvasSize canvasSize
- $ Network.empty
- )
- in Right (network, warnings, False)
+ case xmlParse' "input file" xml of
+ Left err -> Left err -- lexical or initial (generic) parse error
+ Right (Document _ _ e _) ->
+ case runXMLParser parseContents [CElem e noPos] of
+ Left err -> Left err -- secondary (typeful) parse error
+ Right (v,_) -> Right (v,[],False)
hunk ./src/NetworkFile.hs 45
+-- non-XML output
hunk ./src/NetworkFile.hs 66
--- Convert our data type to an XML tree and print it
+-- Internal type isomorphic to (index,value) pairs
+-- (but permits instances of classes)
hunk ./src/NetworkFile.hs 69
+data AssocN a = AssocN Int (Node a)
+deAssocN :: AssocN a -> (Int,Node a)
+deAssocN (AssocN n v) = (n,v)
+data AssocE = AssocE Int Edge
+deAssocE :: AssocE -> (Int,Edge)
+deAssocE (AssocE n v) = (n,v)
hunk ./src/NetworkFile.hs 76
-toStringXML :: Network String -> String
-toStringXML network = render . Pretty.document $
- Document (Prolog Nothing [] Nothing []) emptyST
- (Elem "Network" []
- [ simpleString "Width" (show width)
- , simpleString "Height" (show height)
- , makeTag "Nodes" (nodesToXML nodeAssocs)
- , makeTag "Edges" (edgesToXML edgeAssocs)
- ]
- ) []
- where
- nodeAssocs = getNodeAssocs network
- edgeAssocs = getEdgeAssocs network
- (width, height) = getCanvasSize network
+---------------------------------------------------------
+-- Convert our data type to/from an XML tree
+---------------------------------------------------------
+instance (Haskell2XmlNew a, InfoKind a) => Haskell2XmlNew (Network a) where
+ toHType _ =
+ Defined "Network" []
+ [Constr "Network" [] []]
+ toContents network = [_$_]
+ [CElem (Elem "Network" []
+ [ simpleString "Width" (show width)
+ , simpleString "Height" (show height)
+ , makeTag "Nodes" (concatMap toContents nodeAssocs)
+ , makeTag "Edges" (concatMap toContents edgeAssocs)
+ ]) () ]
+ where
+ nodeAssocs = map (uncurry AssocN) $ getNodeAssocs network
+ edgeAssocs = map (uncurry AssocE) $ getEdgeAssocs network
+ (width, height) = getCanvasSize network
+ parseContents = do
+ { element' ["Network"] $ do
+ { w <- element' ["Width"] $ fmap read XML.text
+ ; h <- element' ["Height"] $ fmap read XML.text
+ ; ns <- element' ["Nodes"] $ nonemptylist parseContents
+ ; es <- element' ["Edges"] $ nonemptylist parseContents
+ ; networkValid ns es
+ ; return ( setCanvasSize (w,h)
+ . setNodeAssocs (map deAssocN ns)
+ . setEdgeAssocs (map deAssocE es)
+ $ Network.empty)
+ }
+ }
hunk ./src/NetworkFile.hs 108
-nodesToXML :: [(Int, Node String)] -> [Content]
-nodesToXML ns =
- [ tagWithId "Node" ('N':show nodeNr)
- [ simpleString "LabelAbove" (show (getNameAbove node))
- , simpleString "X" (show x)
+instance (Haskell2XmlNew a, InfoKind a) => Haskell2XmlNew (AssocN a) where
+ toHType _ =
+ Defined "Node" []
+ [Constr "Node" [] []]
+ toContents (AssocN n node) =
+ concatMap (replaceAttrs [("id",'N':show n)]) (toContents node)
+ parseContents = do
+ { [("id",n)] <- peekAttributes ["Node"]
+ ; n' <- num n
+ ; node <- parseContents
+ ; return (AssocN n' node)
+ }
+ where num (AttValue [Left ('N':n)]) = return (read n)
+ num (AttValue s) = fail ("Problem reading Node ID: "++verbatim s)
+
+instance Haskell2XmlNew AssocE where
+ toHType _ =
+ Defined "Edge" []
+ [Constr "Edge" [] []]
+ toContents (AssocE n edge) =
+ concatMap (replaceAttrs [("id",'E':show n)]) (toContents edge)
+ parseContents = do
+ { [("id",n)] <- peekAttributes ["Edge"]
+ ; n' <- num n
+ ; edge <- parseContents
+ ; return (AssocE n' edge)
+ }
+ where num (AttValue [Left ('E':n)]) = return (read n)
+ num (AttValue s) = fail ("Problem reading Edge ID: "++verbatim s)
+
+instance (Haskell2XmlNew a, InfoKind a) => Haskell2XmlNew (Node a) where
+ toHType _ =
+ Defined "Node" []
+ [Constr "Node" [] []]
+ toContents node =
+ [ makeTag "Node"
+ (toContents (getPosition node) ++
+ [ escapeString "Name" (getName node)
+ , simpleString "LabelAbove" (show (getNameAbove node))
+ , makeTag "Shape" (toContents (getShape node))
+ , makeTag "Info" (toContents (getInfo node))
+ ])
+ ]
+ parseContents = do
+ { element' ["Node"] $ do
+ { p <- parseContents -- position
+ ; n <- element' ["Name"] $ XML.text
+ ; a <- element' ["LabelAbove"] $ fmap read XML.text
+ ; s <- element' ["Shape"] $ parseContents
+ ; i <- element' ["Info"] $ parseContents
+ ; return ( Node.setShape s
+ . Node.setInfo i
+ $ Node.create n p a)
+ }
+ }
+
+instance Haskell2XmlNew DoublePoint where
+ toHType _ =
+ Defined "DoublePoint" []
+ [Constr "X" [] [],
+ Constr "Y" [] []]
+ toContents (DoublePoint x y) = [_$_]
+ [ simpleString "X" (show x)
hunk ./src/NetworkFile.hs 172
- , escapeString "Name" (getName node)
- , simpleString "Shape" (show (getShape node))
hunk ./src/NetworkFile.hs 173
- | (nodeNr, node) <- ns
- , let position = getPosition node
- x = doublePointX position
- y = doublePointY position
- ]
+ parseContents = do
+ { x <- element' ["X"] $ fmap read XML.text
+ ; y <- element' ["Y"] $ fmap read XML.text
+ ; return (DoublePoint x y)
+ }
hunk ./src/NetworkFile.hs 179
-edgesToXML :: [(Int, Edge)] -> [Content]
-edgesToXML es =
- [ tagWithId "Edge" ('E':show edgeNr)
- [ simpleString "From" (show (edgeFrom edge))
- , simpleString "To" (show (edgeTo edge))
- , simpleString "Via" (show (edgeVia edge))
+instance Haskell2XmlNew Edge where
+ toHType _ =
+ Defined "Edge" []
+ [Constr "Edge" [] []]
+ toContents edge =
+ [ makeTag "Edge"
+ [ simpleString "From" (show (edgeFrom edge))
+ , simpleString "To" (show (edgeTo edge))
+ , makeTag "Via" (concatMap toContents (edgeVia edge))
+ ]
hunk ./src/NetworkFile.hs 190
- | (edgeNr, edge) <- es
- ]
+ parseContents = do
+ { element' ["Edge"] $ do
+ { f <- element' ["From"] $ fmap read XML.text
+ ; t <- element' ["To"] $ fmap read XML.text
+ ; v <- element' ["Via"] $ list parseContents
+ ; return (Edge { edgeFrom=f, edgeTo=t, edgeVia=v })
+ }
+ }
hunk ./src/NetworkFile.hs 199
+{- derived by DrIFT -}
+instance Haskell2XmlNew Colour where
+ toHType v =
+ Defined "Colour" []
+ [Constr "RGB" [] [toHType aa,toHType ab,toHType ac]]
+ where
+ (RGB aa ab ac) = v
+ parseContents = do
+ { element' ["RGB"] $ do
+ { aa <- parseContents
+ ; ab <- parseContents
+ ; ac <- parseContents
+ ; return (RGB aa ab ac)
+ }
+ }
+ toContents v@(RGB aa ab ac) =
+ [mkElemC (showConstr 0 (toHType v))
+ (concat [toContents aa, toContents ab, toContents ac])]
+
+{- derived by DrIFT -}
+instance Haskell2XmlNew Shape where
+ toHType v =
+ Defined "Shape" []
+ [Constr "Circle" [] [toHType aa,toHType ab],
+ Constr "Polygon" [] [toHType ac,toHType ad],
+ Constr "Lines" [] [toHType ae,toHType af],
+ Constr "Composite" [] [toHType ag]]
+ where
+ (Circle aa ab) = v
+ (Polygon ac ad) = v
+ (Lines ae af) = v
+ (Composite ag) = v
+ parseContents = do
+ { e@(Elem t _ _) <- element ["Circle","Polygon","Lines","Composite"]
+ ; case t of
+ _ | "Polygon" `isPrefixOf` t -> interior e $
+ do { ac <- parseContents
+ ; ad <- parseContents
+ ; return (Polygon ac ad)
+ }
+ | "Lines" `isPrefixOf` t -> interior e $
+ do { ae <- parseContents
+ ; af <- parseContents
+ ; return (Lines ae af)
+ }
+ | "Composite" `isPrefixOf` t -> interior e $
+ fmap Composite parseContents
+ | "Circle" `isPrefixOf` t -> interior e $
+ do { aa <- parseContents
+ ; ab <- parseContents
+ ; return (Circle aa ab)
+ }
+ }
+ toContents v@(Circle aa ab) =
+ [mkElemC (showConstr 0 (toHType v)) (concat [toContents aa,
+ toContents ab])]
+ toContents v@(Polygon ac ad) =
+ [mkElemC (showConstr 1 (toHType v)) (concat [toContents ac,
+ toContents ad])]
+ toContents v@(Lines ae af) =
+ [mkElemC (showConstr 2 (toHType v)) (concat [toContents ae,
+ toContents af])]
+ toContents v@(Composite ag) =
+ [mkElemC (showConstr 3 (toHType v)) (toContents ag)]
+
+{- derived by DrIFT -}
+instance Haskell2XmlNew ShapeStyle where
+ toHType v =
+ Defined "ShapeStyle" []
+ [Constr "ShapeStyle" [] [toHType aa,toHType ab,toHType ac]]
+ where
+ (ShapeStyle aa ab ac) = v
+ parseContents = do
+ { element' ["ShapeStyle"] $ do
+ { aa <- parseContents
+ ; ab <- parseContents
+ ; ac <- parseContents
+ ; return (ShapeStyle aa ab ac)
+ }
+ }
+ toContents v@(ShapeStyle aa ab ac) =
+ [mkElemC (showConstr 0 (toHType v))
+ (concat [toContents aa, toContents ab, toContents ac])]
+
+
hunk ./src/NetworkFile.hs 287
-makeTag :: String -> [Content] -> Content
-makeTag name children = CElem (Elem name [] children)
+makeTag :: String -> [Content i] -> Content i
+makeTag name children = CElem (Elem name [] children) undefined
hunk ./src/NetworkFile.hs 290
-tagWithId :: String -> String -> [Content] -> Content
+tagWithId :: String -> String -> [Content i] -> Content i
hunk ./src/NetworkFile.hs 292
- CElem (Elem name [("id", AttValue [Left identity])] children)
+ CElem (Elem name [("id", AttValue [Left identity])] children) undefined
hunk ./src/NetworkFile.hs 295
-simpleString :: String -> String -> Content
+simpleString :: String -> String -> Content i
hunk ./src/NetworkFile.hs 297
- CElem $ Elem tag [] [ CString False value ]
+ CElem (Elem tag [] [ CString False value undefined ]) undefined
hunk ./src/NetworkFile.hs 300
-escapeString :: String -> String -> Content
-escapeString key value = CElem . (if isSafe value then id else escape) $
- Elem key [] [ CString (any isSpace value) value ]
+escapeString :: String -> String -> Content i
+escapeString key value =
+ CElem ((if isSafe value then id else escape) $
+ Elem key [] [ CString (any isSpace value) value undefined ])
+ undefined
hunk ./src/NetworkFile.hs 309
- escape :: Element -> Element
+ escape :: Element i -> Element i
hunk ./src/NetworkFile.hs 312
-comment :: String -> Content
-comment s = CMisc $ Comment (commentEscape s)
+comment :: String -> Content i
+comment s = CMisc (Comment (commentEscape s)) undefined
hunk ./src/NetworkFile.hs 323
--- "Parsing" the XML tree into our data type
----------------------------------------------------------
-
--- Error monad combined with an output monad for warnings
-data MessageMonad a = MM (Either String (a, [String]))
-
--- m a -> (a -> m b) -> m b
-instance Monad MessageMonad where
- return x = MM (Right (x, []))
- (MM ma) >>= f = MM $ case ma of
- Left err -> Left err
- Right (x, ws1) ->
- case runMM (f x) of
- Left err -> Left err
- Right (y, ws2) -> Right (y, ws1 ++ ws2)
-
-issueWarning :: String -> MessageMonad ()
-issueWarning s = MM (Right ((), [s]))
-
-issueError :: String -> MessageMonad a
-issueError s = MM (Left s)
-
-runMM :: MessageMonad a -> Either String (a, [String])
-runMM (MM x) = x
-
--- End of monad
-
-type NetworkComponents =
- ( [(NodeNr, Node String)]
- , [(EdgeNr, Edge)]
- , (Double, Double)
- )
-
--- Does not return a network because we first have to check for validity
--- (and duplicate node number would be lost if we would build a network)
-fromStringXML :: String -> Either String (NetworkComponents, [String])
-fromStringXML s =
- case xmlParse' "filename" s of
- Left err -> Left err -- parse error
- Right document -> runMM (docToNet document)
-
-docToNet :: Document -> MessageMonad NetworkComponents
-docToNet (Document prolog symbolTable element _) =
- do{ case prolog of
- Prolog Nothing _ Nothing _ -> return ()
- _ -> issueWarning "Ignoring non-empty prolog"
- ; case symbolTable of
- [] -> return ()
- _ -> issueWarning "Ignoring non-empty symbol table"
- ; networkTag element
- }
-
-networkTag :: Element -> MessageMonad NetworkComponents
-networkTag (Elem "Network" attrs contents) =
- do{ warnIfAttributes attrs "Network"
-
- ; width <- getDoubleInsideTag "Width" contents "Network"
- ; height <- getDoubleInsideTag "Height" contents "Network"
-
- ; nodesElt <- findUniqueChildWithTag "Nodes" contents "Network"
- ; nodeAssocs <- nodesTag nodesElt
-
- ; edgesElt <- findUniqueChildWithTag "Edges" contents "Network"
- ; edgeAssocs <- edgesTag edgesElt
-
- ; warnAboutSuperfluousContents ["Width", "Height", "Nodes", "Edges"] contents "Network"
-
- ; return (nodeAssocs, edgeAssocs, (width, height))
- }
-networkTag _ =
- issueError "Expecting \"Network\" tag as outermost tag"
-
-nodesTag :: Element -> MessageMonad [(NodeNr, Node String)]
-nodesTag (Elem _ attrs contents) =
- do{ warnIfAttributes attrs "Nodes"
- ; let nodeElts = findChildrenWithTag "Node" contents
- ; nodeAssocs <- mapM nodeTag nodeElts
- ; warnAboutSuperfluousContents ["Node"] contents "Nodes"
- ; return nodeAssocs
- }
-
-nodeTag :: Element -> MessageMonad (NodeNr, Node String)
-nodeTag (Elem _ attrs contents) =
- do{ identity <- getIdAttribute attrs "Node"
- ; when (null identity || head identity /= 'N' || not (all isDigit (tail identity))) $
- do { issueError $ "Node identity (" ++ identity ++
- ") should be N followed by a number" }
- ; let nr = read (tail identity) :: Int
-
- ; labelAbove <- getBoolInsideTag "LabelAbove" contents "Node"
- ; x <- getDoubleInsideTag "X" contents "Node"
- ; y <- getDoubleInsideTag "Y" contents "Node"
- ; name <- getStringInsideTag "Name" contents "Node"
- ; shape <- getStringInsideTag "Shape" contents "Node"
-
- ; warnAboutSuperfluousContents
- ["LabelAbove", "X", "Y", "Name", "Shape" ]
- contents "Node"
-
- ; return ( nr
- , setShape (read shape) $
- Node.create name (DoublePoint x y) labelAbove
- )
- }
-
-edgesTag :: Element -> MessageMonad [(EdgeNr, Edge)]
-edgesTag (Elem _ attrs contents) =
- do{ warnIfAttributes attrs "Edges"
- ; let edgeElts = findChildrenWithTag "Edge" contents
- ; edgeAssocs <- mapM edgeTag edgeElts
- ; warnAboutSuperfluousContents ["Edge"] contents "Edges"
- ; return edgeAssocs
- }
-
-edgeTag :: Element -> MessageMonad (EdgeNr, Edge)
-edgeTag (Elem _ attrs contents) =
- do{ identity <- getIdAttribute attrs "Edge"
- ; when (null identity || head identity /= 'E' || not (all isDigit (tail identity))) $
- do { issueError $ "Edge identity (" ++ identity ++
- ") should be E followed by a number" }
- ; let nr = read (tail identity) :: Int
-
- ; fromNr <- getIntInsideTag "From" contents "Edge"
- ; toNr <- getIntInsideTag "To" contents "Edge"
- ; via <- getStringInsideTag "Via" contents "Edge"
-
- ; warnAboutSuperfluousContents ["From", "To", "Via"] contents "Edge"
-
- ; return (nr, Edge { edgeFrom = fromNr, edgeTo = toNr
- , edgeVia = (read via) })
- }
-
-
----- UTILITY FUNCTIONS
-
-getIdAttribute :: [Attribute] -> String -> MessageMonad String
-getIdAttribute attrs parent =
- do{ let ids = [ value | (name, value) <- attrs, name == "id" ]
- ; when (length ids /= 1) $
- do{ issueError $
- if length ids == 0 then
- "Missing attribute \"id\" at tag " ++ show parent
- else
- "More than one attribute \"id\" at tag " ++ show parent
- }
- ; let idAttValue = head ids
- ; identity <- case idAttValue of
- AttValue [Left s] -> return s
- _ -> issueError $ "Expecting string as value of \"id\" attribute at tag " ++ show parent
- ; when (length attrs > 1) $
- do{ issueWarning $ "Ignoring attributes other than \"id\" at tag " ++ show parent }
- ; return identity
- }
-
-warnAboutSuperfluousContents :: [String] -> [Content] -> String -> MessageMonad ()
-warnAboutSuperfluousContents tags contents parent =
- when (not (null
- [ content
- | content <- contents
- , case content of
- CElem (Elem tag _ _) -> tag `notElem` tags
- CMisc (Comment _) -> False -- do not warn about comments
- _ -> True
- ])) $
- do{ issueWarning $ "Ignoring superfluous children inside tag " ++ show parent ++
- " (expecting only " ++ commasAnd (map show tags) ++ ")"
- }
-
--- | Give a warning if the list of attributes is not empty
--- For most tags we don't want attributes
-warnIfAttributes :: [Attribute] -> String -> MessageMonad ()
-warnIfAttributes attrs tagName =
- when (not (null attrs)) $
- do{ issueWarning $ "Ignoring unexpected attributes at " ++
- show tagName ++ " tag"
- }
-
--- | Get the integer value of the string inside the child with the given tag
-getIntInsideTag :: String -> [Content] -> String -> MessageMonad Int
-getIntInsideTag tagName contents parent =
- do{ txt <- getStringInsideTag tagName contents parent
- ; case reads txt of
- ((number, []):_) -> return number
- _ -> issueError $ "Expecting string inside " ++ show tagName ++
- " to be an integer value. String = " ++ txt
- }
-
--- | Get the boolean value of the string inside the child with the given tag
-getBoolInsideTag :: String -> [Content] -> String -> MessageMonad Bool
-getBoolInsideTag tagName contents parent =
- do{ txt <- getStringInsideTag tagName contents parent
- ; case txt of
- "True" -> return True
- "False" -> return False
- _ -> issueError $ "Expecting string inside " ++ show tagName ++
- " to be a boolean value (True or False). String = " ++ txt
- }
-
--- | Get the double value of the string inside the child with the given tag
-getDoubleInsideTag :: String -> [Content] -> String -> MessageMonad Double
-getDoubleInsideTag tagName contents parent =
- do{ txt <- getStringInsideTag tagName contents parent
- ; case parseDouble txt of
- Nothing -> issueError $ "Expecting string inside " ++ show tagName ++
- " to be a floating-point number. String = " ++ txt
- Just x -> return x
- }
-
--- | Finds the child with the correct tag and returns the string inside it
-getStringInsideTag :: String -> [Content] -> String -> MessageMonad String
-getStringInsideTag tagName contents parent =
- do{ elt <- findUniqueChildWithTag tagName contents parent
- ; let (Elem _ attrs children) = xmlUnEscape stdXmlEscaper elt
- ; warnIfAttributes attrs tagName
- ; getString children tagName
- }
-
--- | Finds all children with the correct tag and returns the strings inside them
-getStringsInsideTags :: String -> [Content] -> MessageMonad [String]
-getStringsInsideTags tagName contents =
- do{ let elts = findChildrenWithTag tagName contents
- unescapedElts = map (xmlUnEscape stdXmlEscaper) elts
- ; foreach unescapedElts $ \(Elem _ attrs subContents) ->
- do{ warnIfAttributes attrs tagName
- ; getString subContents tagName
- }
- }
-
--- Expects the list of children to have length one and contain a string
--- Returns this string and otherwise issues and error
-getString :: [Content] -> String -> MessageMonad String
-getString [CString _ txt] _ = return txt
-getString _ parent =
- issueError $ "Expecting a string inside tag " ++ show parent
-
-instance Show Content where
- show c = case c of
- CElem (Elem tag _ _) -> "element with tag " ++ show tag
- CString _ s -> "string \"" ++ s ++ "\""
- CRef _ -> "reference"
- CMisc (Comment _) -> "comment"
- CMisc _ -> "processing instruction"
-
--- | Look up a tag and make sure there is exactly one. Otherwise,
--- an error is issued
-findUniqueChildWithTag :: String -> [Content] -> String -> MessageMonad Element
-findUniqueChildWithTag name contents parent =
- do{ let matches = findChildrenWithTag name contents
- ; when (length matches /= 1) $
- issueError (
- if (length matches == 0) then
- "Missing tag " ++ show name ++ " inside tag " ++ show parent
- else
- "More than one tag " ++ show name ++ " inside tag " ++ show parent
- )
- ; return (head matches)
- }
-
--- | Looks up a tag with given name in a list of Contents
--- It returns the elements with the correct tag
--- (there might be 0 or more than 1)
-findChildrenWithTag :: String -> [Content] -> [Element]
-findChildrenWithTag name contents =
- [ case content of
- CElem elt -> elt
- _ -> internalError "NetworkFile" "findChildrenWithTag" "should have been filtered out"
- | content <- contents
- , case content of
- CElem (Elem tag _ _) -> tag == name
- _ -> False
- ]
-
----------------------------------------------------------
hunk ./src/NetworkFile.hs 326
-networkValid :: NetworkComponents -> MessageMonad ()
-networkValid (nodeAssocs, edgeAssocs, _)
+networkValid :: [AssocN a] -> [AssocE] -> XMLParser ()
+networkValid nodeAssocs edgeAssocs
hunk ./src/NetworkFile.hs 329
- issueError "Node numbers should be unique"
+ fail "Node numbers should be unique"
hunk ./src/NetworkFile.hs 331
- issueError "Edge numbers should be unique"
+ fail "Edge numbers should be unique"
hunk ./src/NetworkFile.hs 333
- do{ mapM (checkEdge nodeNrs) edgeAssocs
+ do{ mapM_ (checkEdge nodeNrs) edgeAssocs
hunk ./src/NetworkFile.hs 337
- issueError $ "There are multiple edges between the following node pairs: " ++
+ fail $ "There are multiple edges between the following node pairs: " ++
hunk ./src/NetworkFile.hs 344
- (nodeNrs, _ ) = unzip nodeAssocs
- (edgeNrs, edges) = unzip edgeAssocs
+ nodeNrs = map (fst . deAssocN) nodeAssocs
+ (edgeNrs, edges) = unzip (map deAssocE edgeAssocs)
hunk ./src/NetworkFile.hs 349
-checkEdge :: [NodeNr] -> (EdgeNr, Edge) -> MessageMonad ()
-checkEdge nodeNrs (edgeNr, Edge fromNr toNr _)
+checkEdge :: [NodeNr] -> AssocE -> XMLParser ()
+checkEdge nodeNrs (AssocE edgeNr (Edge fromNr toNr _))
hunk ./src/NetworkFile.hs 352
- issueError $ "Edge " ++ show edgeNr ++ ": from-node and to-node are the same"
+ fail $ "Edge " ++ show edgeNr ++ ": from-node and to-node are the same"
hunk ./src/NetworkFile.hs 358
- issueError $ "Edge " ++ show edgeNr ++ ": refers to non-existing node " ++ show nodeNr
+ fail $ "Edge " ++ show edgeNr ++ ": refers to non-existing node "
+ ++ show nodeNr
}