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. 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/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 diff --git a/src/Pangraph/Internal/HexmlExtra.hs b/src/Pangraph/Internal/HexmlExtra.hs index a9b8d03..1d95ad0 100644 --- a/src/Pangraph/Internal/HexmlExtra.hs +++ b/src/Pangraph/Internal/HexmlExtra.hs @@ -5,24 +5,51 @@ import Data.ByteString (ByteString) import Text.XML.Hexml import Pangraph --- * 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. +-- * 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 + +-- | 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 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 + +-- | 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 diff --git a/src/Pangraph/Workcraft/Internal.hs b/src/Pangraph/Workcraft/Internal.hs new file mode 100644 index 0000000..53cfc26 --- /dev/null +++ b/src/Pangraph/Workcraft/Internal.hs @@ -0,0 +1,70 @@ +{-# 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 + -- 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 new file mode 100644 index 0000000..7408b9a --- /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) + +-- | 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 + 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 a = fromJust . lookup a + in buildPangraph (hexmlParse bs) vf ef \ No newline at end of file