From f2014ea7ecc83abbf7b74511ff5aed2a3d9749ca Mon Sep 17 00:00:00 2001 From: jscott Date: Sun, 23 Sep 2018 15:07:34 +0100 Subject: [PATCH 1/6] Added alias type for Pangraph and Hexml attributes in Pangraph.Internal.HexmlExtra --- src/Pangraph/Internal/HexmlExtra.hs | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/src/Pangraph/Internal/HexmlExtra.hs b/src/Pangraph/Internal/HexmlExtra.hs index a9b8d03..24037ff 100644 --- a/src/Pangraph/Internal/HexmlExtra.hs +++ b/src/Pangraph/Internal/HexmlExtra.hs @@ -5,6 +5,8 @@ import Data.ByteString (ByteString) import Text.XML.Hexml import Pangraph +type HexmlAttribute = Text.XML.Hexml.Attribute +type PangraphAttribute = Pangraph.Attribute -- * A module containing some exclusivly Hexml helper functions and some which have common interfacing functions. -- | Find the ['Node'] with the final in the ['ByteString'] after following the @@ -23,6 +25,6 @@ hexmlParse file = case parse file of Left l -> error $ "HexML parser failed:\n" ++ show l -- | Converts a between the two libaries Attribute types. -convertAtt :: Text.XML.Hexml.Attribute -> Pangraph.Attribute +convertAtt :: HexmlAttribute -> PangraphAttribute convertAtt a = (attributeName a, attributeValue a) \ No newline at end of file From 91008de305d46d9564cb70fb1289a8e698152bd1 Mon Sep 17 00:00:00 2001 From: jscott Date: Tue, 25 Sep 2018 19:57:34 +0100 Subject: [PATCH 2/6] Add followChildren, followChildrenFilterThenApplyFunction and attributesBy to Pangraph.Internal.HexmlExtra --- src/Pangraph/Internal/HexmlExtra.hs | 45 ++++++++++++++++++++++------- 1 file changed, 35 insertions(+), 10 deletions(-) diff --git a/src/Pangraph/Internal/HexmlExtra.hs b/src/Pangraph/Internal/HexmlExtra.hs index 24037ff..ac180ce 100644 --- a/src/Pangraph/Internal/HexmlExtra.hs +++ b/src/Pangraph/Internal/HexmlExtra.hs @@ -5,20 +5,26 @@ import Data.ByteString (ByteString) import Text.XML.Hexml import Pangraph -type HexmlAttribute = Text.XML.Hexml.Attribute + +-- * A module containing containing extra Hexml functions as well as functons to ease conversions between the libraries. + +type HexmlAttribute = Text.XML.Hexml.Attribute type PangraphAttribute = Pangraph.Attribute --- * A module containing some exclusivly Hexml helper functions and some which have common interfacing functions. --- | Find the ['Node'] with the final in the ['ByteString'] after following the --- 'Node' names recursively. +-- | Find the ['Node'] with the final name in the ['ByteString'] after following the 'Node' names recursively, including the root node's name. +-- Given `[]` returns '[]'. followChildren :: Node -> [ByteString] -> [Node] -followChildren h [] = [h] -followChildren h bs = (concatMap recurse . childrenBy h) (head bs) +followChildren _ [] = [] +followChildren h bs = if head bs == name h + then concatMap (`recurse` tail bs) $ childrenBy h (bs !! 1) + else error $ "Followchildren failed (Did you include the root name?):\n" ++ show h ++ "\n Bytestring: \n" ++ show bs where - recurse :: Node -> [Node] - recurse n = followChildren n (tail bs) + recurse :: Node -> [ByteString] -> [Node] + recurse _ [] = error "Recurse called on empty Bytestring" + recurse h' [_] = [h'] + recurse h' bs' = concatMap (`recurse` tail bs') $ childrenBy h' (bs' !! 1) --- An unsafe version of the 'Text.XML.Hexml.parse' upon failure throws error to stderr. +-- An unsafe version of the 'Text.XML.Hexml.parse' upon failure throws error to stderr, showing the resulting error message. hexmlParse :: ByteString -> Node hexmlParse file = case parse file of Right t -> t @@ -27,4 +33,23 @@ hexmlParse file = case parse file of -- | Converts a between the two libaries Attribute types. convertAtt :: HexmlAttribute -> PangraphAttribute convertAtt a = (attributeName a, attributeValue a) - \ No newline at end of file + +-- | Extend `H.attributeBy` to lists. +attributesBy :: [ByteString] -> Node -> [Maybe HexmlAttribute] +attributesBy bs h = map (attributeBy h) bs + +-- | Traverse the Hexml node tree using `followChildren` apply a filter to its results and apply a function to the remaining nodes. +-- The resulting `Node`s are then filtered and have a function applied. +-- The function `(Node -> a)` may then return the data from this node or its children. +followChildrenFilterThenApplyFunction + :: Node + -> [ByteString] + -> (Node -> Bool) + -> (Node -> a) + -> [a] +followChildrenFilterThenApplyFunction + root nodePath filterPredicate callerFunc = + ( map callerFunc + . filter filterPredicate + . followChildren root + ) nodePath From e75305d12b2ee197272da812ef460ff9bc5f4894 Mon Sep 17 00:00:00 2001 From: jscott Date: Wed, 26 Sep 2018 10:37:30 +0100 Subject: [PATCH 3/6] Add instance of buildGraph too Pangraph.WorkCraft.Internal and drive it from Pangraph.Workcraft.Parse.parse. --- pangraph.cabal | 2 + src/Pangraph/Workcraft/Internal.hs | 59 ++++++++++++++++++++++++++++++ src/Pangraph/Workcraft/Parser.hs | 26 +++++++++++++ 3 files changed, 87 insertions(+) create mode 100644 src/Pangraph/Workcraft/Internal.hs create mode 100644 src/Pangraph/Workcraft/Parser.hs diff --git a/pangraph.cabal b/pangraph.cabal index 3de636e..b2317f5 100644 --- a/pangraph.cabal +++ b/pangraph.cabal @@ -38,6 +38,8 @@ library , Pangraph.Gml.Ast , Pangraph.Gml.Parser , Pangraph.Gml.Writer + , Pangraph.Workcraft.Parser + , Pangraph.Workcraft.Internal build-depends: base >= 4.8 && < 5 , algebraic-graphs == 0.2.* , attoparsec == 0.13.* diff --git a/src/Pangraph/Workcraft/Internal.hs b/src/Pangraph/Workcraft/Internal.hs new file mode 100644 index 0000000..5aee6cd --- /dev/null +++ b/src/Pangraph/Workcraft/Internal.hs @@ -0,0 +1,59 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Pangraph.Workcraft.Internal where + +import Data.ByteString (ByteString) + +import qualified Text.XML.Hexml as H +import qualified Pangraph.Internal.HexmlExtra as H + +import Pangraph +import Pangraph.Internal.ProtoGraph + +import Data.Maybe (fromJust) + +newtype WorkcraftAST = WorkcraftAST H.Node + deriving (Show) + +unwrap :: WorkcraftAST -> H.Node +unwrap (WorkcraftAST n) = n + +render :: WorkcraftAST -> ByteString +render (WorkcraftAST h) = H.render h + +instance BuildPangraph WorkcraftAST where + -- + -- + -- + getProtoVertex (WorkcraftAST h) = let + isVertex :: H.Node -> Bool + isVertex h'= (H.attributeValue <$> H.attributeBy h' "class") == Just "org.workcraft.plugins.graph.Vertex" + extractVertexData :: H.Node -> [Attribute] + extractVertexData = map (H.convertAtt . fromJust) . H.attributesBy ["ref"] + traverseNodeTree :: [[Attribute]] + traverseNodeTree = H.followChildrenFilterThenApplyFunction h xmlNodePath isVertex extractVertexData + in map makeProtoVertex traverseNodeTree + + -- + -- + -- + getProtoEdge (WorkcraftAST h) = let + isEdge :: H.Node -> Bool + isEdge h'= (H.attributeValue <$> H.attributeBy h' "class") == Just "org.workcraft.dom.math.MathConnection" + extractEdgeData :: H.Node -> [Attribute] + extractEdgeData h' = let + child = (head $ H.followChildren h' ["node", "MathConnection"]) + in map (H.convertAtt . fromJust) + (H.attributesBy ["ref"] h' + ++ H.attributesBy ["first", "second"] child) + + in map makeProtoEdge $ H.followChildrenFilterThenApplyFunction h xmlNodePath isEdge extractEdgeData + +hexmlParse :: ByteString -> WorkcraftAST +hexmlParse = WorkcraftAST . getRealRoot . H.hexmlParse + +getRealRoot :: H.Node -> H.Node +getRealRoot h = H.children h !! 1 + +xmlNodePath :: [ByteString] +xmlNodePath = ["model", "root", "node"] \ No newline at end of file diff --git a/src/Pangraph/Workcraft/Parser.hs b/src/Pangraph/Workcraft/Parser.hs new file mode 100644 index 0000000..d0337fc --- /dev/null +++ b/src/Pangraph/Workcraft/Parser.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Pangraph.Workcraft.Parser ( + parse +) where + +import Pangraph +import Pangraph.Internal.ProtoGraph +import Pangraph.Workcraft.Internal + +import Data.Maybe (fromJust) + +import Data.ByteString(ByteString) + +parse :: ByteString -> Maybe Pangraph +parse bs = let + vf :: ProtoVertex -> VertexID + vf v = f "ref" (protoVertexAttributes v) + ef :: ProtoEdge -> (VertexID, VertexID) + ef e = let + att = protoEdgeAttributes e + in (f "first" att, f "second" att) + f :: ByteString -> [Attribute] -> VertexID + -- f bs as = fromJust $ lookup bs as + f a = fromJust . lookup a + in buildPangraph (hexmlParse bs) vf ef \ No newline at end of file From ecb4305495b5a1f67c3ef890b42c8456b69ba01d Mon Sep 17 00:00:00 2001 From: jscott Date: Wed, 26 Sep 2018 11:01:32 +0100 Subject: [PATCH 4/6] Include Workcraft parsing in Pangraph.Examples --- src/Pangraph/Example.hs | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) diff --git a/src/Pangraph/Example.hs b/src/Pangraph/Example.hs index 1a3e75b..95d1841 100644 --- a/src/Pangraph/Example.hs +++ b/src/Pangraph/Example.hs @@ -1,5 +1,5 @@ module Pangraph.Example where - + import Pangraph.Examples.SampleGraph(smallGraph) import qualified Pangraph.GraphML.Parser as GraphML @@ -10,8 +10,15 @@ import qualified Pangraph.Gml.Writer as Gml import qualified Pangraph.Containers as Containers +import qualified Pangraph.Workcraft.Parser as Workcraft + +import qualified Data.ByteString as BS + main :: IO () main = do + workcraftXML <- BS.readFile "./examples/graphs/model.xml" + print $ Workcraft.parse workcraftXML + -- Serialise and re-parse the graph in to GraphML. let Just gGraphML = (GraphML.parse . GraphML.write) smallGraph -- Test equality From e7d97e83ad68c647fa59034158c84532b5015063 Mon Sep 17 00:00:00 2001 From: jscott Date: Wed, 26 Sep 2018 11:10:47 +0100 Subject: [PATCH 5/6] Finish comments and Haddock --- src/Pangraph/Internal/HexmlExtra.hs | 2 +- src/Pangraph/Workcraft/Internal.hs | 15 +++++++++++++-- src/Pangraph/Workcraft/Parser.hs | 2 +- 3 files changed, 15 insertions(+), 4 deletions(-) diff --git a/src/Pangraph/Internal/HexmlExtra.hs b/src/Pangraph/Internal/HexmlExtra.hs index ac180ce..1d95ad0 100644 --- a/src/Pangraph/Internal/HexmlExtra.hs +++ b/src/Pangraph/Internal/HexmlExtra.hs @@ -6,7 +6,7 @@ import Text.XML.Hexml import Pangraph --- * A module containing containing extra Hexml functions as well as functons to ease conversions between the libraries. +-- * A module containing containing extra Hexml functions as well as functions to ease conversions between the libraries. type HexmlAttribute = Text.XML.Hexml.Attribute type PangraphAttribute = Pangraph.Attribute diff --git a/src/Pangraph/Workcraft/Internal.hs b/src/Pangraph/Workcraft/Internal.hs index 5aee6cd..53cfc26 100644 --- a/src/Pangraph/Workcraft/Internal.hs +++ b/src/Pangraph/Workcraft/Internal.hs @@ -25,35 +25,46 @@ instance BuildPangraph WorkcraftAST where -- -- -- - getProtoVertex (WorkcraftAST h) = let + getProtoVertex (WorkcraftAST h) = let + -- Check the class attribute of the node. isVertex :: H.Node -> Bool isVertex h'= (H.attributeValue <$> H.attributeBy h' "class") == Just "org.workcraft.plugins.graph.Vertex" + -- Extract the fields from the node returning the attributes for a pangraph. extractVertexData :: H.Node -> [Attribute] extractVertexData = map (H.convertAtt . fromJust) . H.attributesBy ["ref"] + -- Traverse the node tree filtering other nodes and extracting data from them. traverseNodeTree :: [[Attribute]] traverseNodeTree = H.followChildrenFilterThenApplyFunction h xmlNodePath isVertex extractVertexData + -- Build the protoVertices in map makeProtoVertex traverseNodeTree -- -- -- getProtoEdge (WorkcraftAST h) = let + -- Check the class property. isEdge :: H.Node -> Bool isEdge h'= (H.attributeValue <$> H.attributeBy h' "class") == Just "org.workcraft.dom.math.MathConnection" + -- Extract values from the attributes and also the relevant values from children. extractEdgeData :: H.Node -> [Attribute] extractEdgeData h' = let + -- Find the child node for this Edge child = (head $ H.followChildren h' ["node", "MathConnection"]) + -- Concat the lists and ready them for Pangraph constructors. in map (H.convertAtt . fromJust) (H.attributesBy ["ref"] h' ++ H.attributesBy ["first", "second"] child) - + -- Construct the ProtoEdges. in map makeProtoEdge $ H.followChildrenFilterThenApplyFunction h xmlNodePath isEdge extractEdgeData +-- A wrapper for hexmlParse to get around the dummy root returned. hexmlParse :: ByteString -> WorkcraftAST hexmlParse = WorkcraftAST . getRealRoot . H.hexmlParse +-- Get the correct root. getRealRoot :: H.Node -> H.Node getRealRoot h = H.children h !! 1 +-- The nodes to follow for the payload. xmlNodePath :: [ByteString] xmlNodePath = ["model", "root", "node"] \ No newline at end of file diff --git a/src/Pangraph/Workcraft/Parser.hs b/src/Pangraph/Workcraft/Parser.hs index d0337fc..7408b9a 100644 --- a/src/Pangraph/Workcraft/Parser.hs +++ b/src/Pangraph/Workcraft/Parser.hs @@ -12,6 +12,7 @@ import Data.Maybe (fromJust) import Data.ByteString(ByteString) +-- | Provided with the 'model.xml' from a Workcraft archive generates the Pangraph of a directed Graph. parse :: ByteString -> Maybe Pangraph parse bs = let vf :: ProtoVertex -> VertexID @@ -21,6 +22,5 @@ parse bs = let att = protoEdgeAttributes e in (f "first" att, f "second" att) f :: ByteString -> [Attribute] -> VertexID - -- f bs as = fromJust $ lookup bs as f a = fromJust . lookup a in buildPangraph (hexmlParse bs) vf ef \ No newline at end of file From 2442ca6a898899c7042c5e189babd02006478b67 Mon Sep 17 00:00:00 2001 From: jscott Date: Wed, 26 Sep 2018 11:13:25 +0100 Subject: [PATCH 6/6] Update readme and changelog --- README.md | 2 +- changelog.md | 1 + 2 files changed, 2 insertions(+), 1 deletion(-) diff --git a/README.md b/README.md index 4d0061c..4123e55 100644 --- a/README.md +++ b/README.md @@ -53,7 +53,7 @@ GraphML files are currently: ### [Workcraft](https://www.workcraft.org/) Workcraft files are currently: -- Parsing: **Unimplemented** +- Parsing: Directed Graphs Only. - Writing: **Unimplemented** ## Graph Library support diff --git a/changelog.md b/changelog.md index 6446ef9..dac692a 100644 --- a/changelog.md +++ b/changelog.md @@ -2,6 +2,7 @@ ## pangraph-0.2.1 * Bump Algebraic Graphs from 0.1.* to 0.2.* +* Add Worcraft parsing via Pangraph.Workcraft.Parser ## pangraph-0.2.0 * Addition of conversion and revert for FGL.