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