diff --git a/README.md b/README.md index cb79af5..d720e05 100644 --- a/README.md +++ b/README.md @@ -1,6 +1,6 @@ # pangraph [![Build Status](https://travis-ci.org/tuura/pangraph.svg?branch=master)](https://travis-ci.org/tuura/pangraph) -Pangraph is a Haskell library which offers for parsing and serializations for graph files. As well as conversions to other Haskell graph formats. An example format is [GraphML](http://graphml.graphdrawing.org/). A graphml file +Pangraph is a Haskell library which offers parsing and serializations for graph files. As well as conversions to other Haskell graph formats. An example format is [GraphML](http://graphml.graphdrawing.org/). A graphml file could for example represent the following graph, with vertices from `A` to `E` and connections, the edges, between them. ![a-sample-graph](examples/graphs/network.svg) Source: @@ -8,11 +8,12 @@ Source: ## Contents 1. [Usage](#usage) -2. [Graph File Support](#graph-file-support) -3. [Library support](#graph-library-support) +2. [Building](#building) +3. [Graph File Support](#graph-file-support) +4. [Library support](#graph-library-support) ## Usage -Pangraph offers an API in the module `Pangraph` for construction and +Pangraph provides an API in the module `Pangraph` for construction and manipulation of graphs. The parsers in the library use this module to generate pangraphs. Parsers and serializers are imported from modules individually. This example shows imports for GraphML. @@ -20,29 +21,23 @@ individually. This example shows imports for GraphML. import Pangraph.GraphML.Parser (parse) import Pangraph.GraphML.Writer (write) ``` -Usage of multiple file types in the same module will require qualified imports. -## Examples -See `src/Pangraph/Examples` for further examples. -### Sample Parsing a Graph -Repeated here is code from `src/Pangraph/Examples/Reading.hs` -```haskell -module Pangraph.Examples.Reading where - -import Prelude hiding (readFile) - -import Data.ByteString (readFile) +Usage of multiple file types in the same module will require +qualified imports. Please see `src/Pangraph/Examples` for further examples. -import Pangraph -import qualified Pangraph.GraphML.Parser as GraphML_P - -main :: IO () -main = do - fileName <- getLine - file <- readFile fileName - print (GraphML_P.parse file) +## Building +```haskell +stack build +stack test ``` ## Graph File Support + +### [GML](https://en.wikipedia.org/wiki/Graph_Modelling_Language) +GML files are currently: +- Parsing: Ok +- Writing: Ok +Node: See `Pangraph.Gml.*` + ### [GraphML](http://graphml.graphdrawing.org/) GraphML files are currently: - Parsing: Ok @@ -62,3 +57,8 @@ Workcraft files are currently: Currently implements: - Convert: `Pangraph.Containers` - Revert: **Unimplemented** + +### [FGL](https://hackage.haskell.org/package/fgl) +Currently implements: +- Convert: `Pangraph.FGL` +- Revert: **Unimplemented** diff --git a/changelog.md b/changelog.md new file mode 100644 index 0000000..4d1b673 --- /dev/null +++ b/changelog.md @@ -0,0 +1,20 @@ +# Changelog + +pangraph-0.2.0 +* Addition of conversion and revert for FGL. +* Addition of Parser, Serializer and AST for GML. +* Change `Edge` types to now only construct with a `VertexID` type. +* Change `edgeEndpoints` to return VertexID. + +pangraph-0.1.2 141360fbc2b6ca232ce91a9b14aa9a626082ba92 08/06/2018 +Note: First Hackage release which follows correct cabal versioning increments. +* Addition of Containers (convert). +* Bump to Stack LTS. +* Update to Algebraic Graphs to build with more versions. + +pangraph-0.1.1.5 49bc8a38842256b7fb7c285725dcfb6dfb03cfcb 03/02/2018 +Note: First hackage release, prior to this on the repo there are many issues with commits. +Note: Commit date earlier. +Note: This list is of all features up to this point. +* Parser and serlizer for subset of Graphml. +* Implementation of Algebraic Graphs. \ No newline at end of file diff --git a/pangraph.cabal b/pangraph.cabal index 1db72f0..23a1eef 100644 --- a/pangraph.cabal +++ b/pangraph.cabal @@ -1,5 +1,5 @@ name: pangraph -version: 0.1.2 +version: 0.2.0 synopsis: A set of parsers for graph languages and conversions to graph libaries. description: A package allowing parsing of graph files into graph @@ -26,10 +26,12 @@ library , Pangraph.GraphML.Parser , Pangraph.GraphML.Writer , Pangraph.Internal.XMLTemplate + , Pangraph.Internal.HexmlExtra , Pangraph.Examples.Reading , Pangraph.Examples.Writing , Pangraph.Examples.ToContainersGraph , Pangraph.Examples.SampleGraph + , Pangraph.Internal.ProtoGraph , Pangraph.Examples.Gml , Pangraph.Gml.Ast , Pangraph.Gml.Parser @@ -38,13 +40,13 @@ library , bytestring , hexml , containers - , algebraic-graphs == 0.1.1.* - , fgl == 5.6.0.0 + , algebraic-graphs + , fgl , attoparsec , text , html-entities default-language: Haskell2010 - GHC-options: -Wall -fwarn-tabs -O2 + GHC-options: -Wall -fwarn-tabs test-suite pangraph-test type: exitcode-stdio-1.0 diff --git a/src/Pangraph.hs b/src/Pangraph.hs index 113d619..c36b46e 100644 --- a/src/Pangraph.hs +++ b/src/Pangraph.hs @@ -1,10 +1,17 @@ +{-| +Module : Pangraph +Description : Exports the core intermediate type for graph representation. + +See `Pangraph` for the type which provides a guaranteed well-formed graph once constructed. The rest of the modules provides constructors and getters on +this type. +-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeFamilies #-} module Pangraph ( -- * Abstract Types Pangraph, Edge, Vertex, Attribute, - Key, Value, VertexID, EdgeID, + Key, Value, VertexID, EdgeID, MalformedEdge, -- * Constructors makePangraph, makeEdge, makeVertex, @@ -26,20 +33,20 @@ import qualified Algebra.Graph.Class as Alga -- | The 'Pangraph' type is the core intermediate type between abstract representations of graphs. data Pangraph = Pangraph - { vertices' :: Map VertexID Vertex - , edges' :: Map EdgeID Edge - } deriving (Eq) + { vertices' :: Map VertexID Vertex + , edges' :: Map EdgeID Edge + } deriving (Eq) -- | A Vertex holds ['Attribute'] and must have a unique 'VertexID' to be constructed with 'makeVertex'. data Vertex = Vertex - { vertexID' :: VertexID - , vertexAttributes' :: [Attribute] - } deriving (Eq) + { vertexID' :: VertexID + , vertexAttributes' :: [Attribute] + } deriving (Eq) -- | Edges also reqiure ['Attribute'] and a tuple of 'Vertex' passed as connections to be constructed with 'makeEdge' data Edge = Edge - { edgeID' :: Maybe EdgeID - , edgeAttributes' :: [Attribute] - , endpoints' :: (Vertex, Vertex) - } deriving (Eq) + { edgeID' :: Maybe EdgeID + , endpoints' :: (VertexID, VertexID) + , edgeAttributes' :: [Attribute] + } deriving (Eq) -- | A type exposed for lookup in the resulting lists. type EdgeID = Int @@ -52,49 +59,49 @@ type Key = BS.ByteString -- | The 'Value' in the tuple that makes up 'Attribute'. type Value = BS.ByteString -type MalformedEdge = (Edge, (Maybe Vertex, Maybe Vertex)) +type MalformedEdge = (Edge, (Maybe VertexID, Maybe VertexID)) instance Show Pangraph where - show p = "makePangraph " ++ show (Map.elems (vertices' p)) ++ " " ++ show (Map.elems (edges' p)) + show p = "makePangraph " ++ show (Map.elems (vertices' p)) ++ " " ++ show (Map.elems (edges' p)) instance Show Vertex where - show (Vertex i as) = unwords ["makeVertex", show i, show as] + show (Vertex i as) = unwords ["makeVertex", show i, show as] instance Show Edge where - show (Edge _ as e) = unwords ["makeEdge", show as, show e] + show (Edge _ e as) = unwords ["makeEdge", show e, show as] instance Alga.ToGraph Pangraph where - type ToVertex Pangraph = Vertex - toGraph p = Alga.vertices (vertexList p) `Alga.overlay` Alga.edges (map edgeEndpoints $ edgeList p) + type ToVertex Pangraph = VertexID + toGraph p = Alga.vertices (map vertexID . vertexList $ p) `Alga.overlay` Alga.edges (map edgeEndpoints $ edgeList p) -- * List based constructors -- | Takes lists of 'Vertex' and 'Edge' to produce 'Just Pangraph' if the graph is correctly formed. makePangraph :: [Vertex] -> [Edge] -> Maybe Pangraph makePangraph vs es = case verifyGraph vertexMap es of - [] -> Just $ Pangraph vertexMap edgeMap - _ -> Nothing - where - vertexMap :: Map VertexID Vertex - vertexMap = Map.fromList $ zip (map vertexID vs) vs - edgeMap :: Map EdgeID Edge - edgeMap = Map.fromList indexEdges - indexEdges :: [(EdgeID, Edge)] - indexEdges = map (\ (i, Edge _ as a) -> (i, Edge (Just i) as a )) $ zip [0..] es + [] -> (Just . Pangraph vertexMap) edgeMap + _ -> Nothing + where + vertexMap :: Map VertexID Vertex + vertexMap = Map.fromList $ zip (map vertexID vs) vs + edgeMap :: Map EdgeID Edge + edgeMap = Map.fromList indexEdges + indexEdges :: [(EdgeID, Edge)] + indexEdges = map (\(i, Edge _ a as) -> (i, Edge (Just i) a as )) $ zip [0..] es verifyGraph :: Map VertexID Vertex -> [Edge] -> [MalformedEdge] -verifyGraph vs = mapMaybe (\e -> lookupEndpoints (e, edgeEndpoints e)) - where - lookupEndpoints :: (Edge, (Vertex, Vertex)) -> Maybe MalformedEdge +verifyGraph vs = let + lookupEndpoints :: (Edge, (VertexID, VertexID)) -> Maybe MalformedEdge lookupEndpoints (e, (v1,v2)) = - case (Map.lookup (vertexID v1) vs, Map.lookup (vertexID v2) vs) of - (Just _ , Just _) -> Nothing - (Nothing, Just _) -> Just (e, (Just v1, Nothing)) - (Just _ , Nothing) -> Just (e, (Nothing, Just v2)) - (Nothing, Nothing) -> Just (e, (Just v1, Just v2)) + case (Map.lookup v1 vs, Map.lookup v2 vs) of + (Just _ , Just _) -> Nothing + (Nothing, Just _) -> Just (e, (Just v1, Nothing)) + (Just _ , Nothing) -> Just (e, (Nothing, Just v2)) + (Nothing, Nothing) -> Just (e, (Just v1, Just v2)) + in mapMaybe (\e -> lookupEndpoints (e, edgeEndpoints e)) -- | Edge constructor -makeEdge :: [Attribute] -> (Vertex, Vertex) -> Edge +makeEdge :: (VertexID, VertexID) -> [Attribute] -> Edge makeEdge = Edge Nothing -- | Vertex constructor @@ -130,7 +137,7 @@ vertexAttributes :: Vertex -> [Attribute] vertexAttributes = vertexAttributes' -- | Returns the endpoint of tupled 'Vertex' of an 'Edge' -edgeEndpoints :: Edge -> (Vertex, Vertex) +edgeEndpoints :: Edge -> (VertexID, VertexID) edgeEndpoints = endpoints' -- | Returns the EdgeID if it has one. 'Edge's are given a new 'EdgeID' when they are passed and retrived from a 'Pangraph' diff --git a/src/Pangraph/Containers.hs b/src/Pangraph/Containers.hs index 5279dc5..215b238 100644 --- a/src/Pangraph/Containers.hs +++ b/src/Pangraph/Containers.hs @@ -1,39 +1,39 @@ +{-| +Module : Pangraph.Containers +Description : Convert `Pangraph` into a CGraph.Graph + +-} module Pangraph.Containers ( convert ) where import Pangraph -import qualified Data.Graph as CGraph -import Data.Maybe (fromMaybe) import Data.List (groupBy, sort) -import Control.Arrow ((***)) +import Data.Maybe (fromMaybe) -import Data.Map.Strict (Map) -import qualified Data.Map.Strict as Map +import qualified Data.Graph as CGraph +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map --- | Transforms a 'Pangraph' in a 'CGraph.Graph'. +-- | Transforms a 'Pangraph' into a 'CGraph.Graph'. convert :: Pangraph -> (CGraph.Graph, CGraph.Vertex -> (Vertex, VertexID, [VertexID]), VertexID -> Maybe CGraph.Vertex) -convert p = CGraph.graphFromEdges getVertices - where - -- A helper function for getting the IDs of endpoints. - edgeEndpointIDs :: Edge -> (VertexID, VertexID) - edgeEndpointIDs e = (vertexID *** vertexID) $ edgeEndpoints e - +convert p = let -- Create an Edge Map using VertexID grouping edge sources together. edgeMap :: Map VertexID [VertexID] - edgeMap = (Map.fromList . groupIDs) $ map edgeEndpointIDs $ edgeList p + edgeMap = (Map.fromList . groupIDs . map edgeEndpoints . edgeList) p - -- Lookup the edges for this vertex. Returning empty list on Nothing. + -- Lookup the edges for this vertex. Returning empty list on Nothing. Which means there are no outgoing arcs. vertexConnections :: Vertex -> [VertexID] vertexConnections v = fromMaybe [] (Map.lookup (vertexID v) edgeMap) -- Convert Pangraph Vertex into a form ready to collect Edges from the Pangraph getVertices :: [(Vertex, VertexID, [VertexID])] getVertices = map (\v ->(v, vertexID v, vertexConnections v)) $ vertexList p + in CGraph.graphFromEdges getVertices groupIDs :: [(VertexID, VertexID)] -> [(VertexID, [VertexID])] -groupIDs vs = map (\ts -> (fst $ head ts, map snd ts)) groupedEdges - where +groupIDs endPoints =let groupedEdges :: [[(VertexID, VertexID)]] - groupedEdges = groupBy (\a b -> fst a == fst b) $ sort vs + groupedEdges = groupBy (\a b -> fst a == fst b) (sort endPoints) + in map (\ts -> (fst $ head ts, map snd ts)) groupedEdges \ No newline at end of file diff --git a/src/Pangraph/Examples/SampleGraph.hs b/src/Pangraph/Examples/SampleGraph.hs index 57dbb6b..1834a42 100644 --- a/src/Pangraph/Examples/SampleGraph.hs +++ b/src/Pangraph/Examples/SampleGraph.hs @@ -5,17 +5,15 @@ module Pangraph.Examples.SampleGraph ) where import Pangraph +import Data.Maybe(fromJust) smallGraph :: Pangraph -smallGraph = case graph of - Just p -> p - Nothing -> error "Small graph literal failed to construct." +smallGraph = fromJust graph where graph = makePangraph [makeVertex "n0" [("id","n0")] ,makeVertex "n1" [("id","n1")] ,makeVertex "n2" [("id","n2")]] - [makeEdge [("source","n0"),("target","n2")] - (makeVertex "n0" [("id","n0")] - ,makeVertex "n2" [("id","n2")])] + [makeEdge ("n0", "n2") + [("source","n0"),("target","n2")]] diff --git a/src/Pangraph/FGL.hs b/src/Pangraph/FGL.hs index 9dd545b..64a85ad 100644 --- a/src/Pangraph/FGL.hs +++ b/src/Pangraph/FGL.hs @@ -1,34 +1,75 @@ -module Pangraph.FGL where +{- +Module : Pangraph.FGL +Description : Provides `convert` and `revert` to a `FGL` form. +The function provides an conversion to FGL in the datatypes `Pangraph` uses. +Users should convert the types as the see fit for example, convert `ByteString` to `Int`. +-} +{-# LANGUAGE OverloadedStrings #-} + +module Pangraph.FGL (convert, revert) where + +-- External Imports +-- ByteString import Data.ByteString (ByteString) +import Data.ByteString.Char8 (pack) +-- FGL import qualified Data.Graph.Inductive.Graph as FGL -import Data.Maybe (fromJust) - +-- Containers import Data.Set (Set) import qualified Data.Set as Set +-- Prelude +import Data.Maybe (fromJust) +import Data.Monoid ((<>)) + +-- Local import Pangraph +import Pangraph.Internal.ProtoGraph --- | Convert a Pangraph to Fgl types +-- | Convert a Pangraph to Fgl types. convert :: Pangraph -> ([FGL.LNode ByteString], [FGL.LEdge Int]) -convert p = - let - -- Create the set of VertexIDs for crossreference when generating FGL.LEdge - vertexSet :: Set VertexID - vertexSet = (Set.fromList . map vertexID . vertexList) p - -- The set of labelled vertices - fglVertices :: [(Int, VertexID)] - fglVertices = zip [0..] (Set.toAscList vertexSet) - -- A helper function for cross referencing a Pangraph Vertex into its order in the set. This index forms a key in FGL. - findIndexOfVertex :: Vertex -> Int - findIndexOfVertex v = Set.findIndex (vertexID v) vertexSet - -- Find the FGL.Node of the Endpoints, using the Set in VertexID. - -- Safely cast the edgeID as its emergence from a Pangraph type enforces it must be Just. - -- The id is formed from the order in the list which are guarrented unique by the pangraph type. - fglEdges :: [(FGL.Node, FGL.Node, Int)] - fglEdges = map ((\(e, (a,b)) -> - (findIndexOfVertex a, findIndexOfVertex b, e)) . - (\e -> ((fromJust . edgeID) e, edgeEndpoints e))) (edgeList p) - in (fglVertices, fglEdges) +convert p = let + -- Create the set of VertexIDs for crossreference when generating FGL.LEdge + vertexSet :: Set VertexID + vertexSet = (Set.fromList . map vertexID . vertexList) p + -- The list of labelled vertices + fglVertices :: [(Int, VertexID)] + fglVertices = zip [0..] (Set.toAscList vertexSet) + -- A helper function for cross referencing a Pangraph Vertex in its order in the set. This index forms a key in FGL. + findIndexOfVertex :: VertexID -> Int + findIndexOfVertex v = Set.findIndex v vertexSet + -- Find the FGL.Node of the Endpoints, using the Set in VertexID. + -- Safely fromJust the edgeID as its emergence from a Pangraph type enforces it Just. + -- The id is formed from the order in the list provided by `vertices` which are guaranteed to be unique by the pangraph type. + fglEdges :: [(FGL.Node, FGL.Node, Int)] + fglEdges = let + in map ((\(e, (a,b)) -> + (findIndexOfVertex a, findIndexOfVertex b, e)) . + (\e -> ((fromJust . edgeID) e, edgeEndpoints e))) (edgeList p) + in (fglVertices, fglEdges) + +-- (Int, ByteString) -> (Int, Int, Int) +-- | Revert FGL types into Pangraph. +revert :: ([FGL.LNode ByteString], [FGL.LEdge Int]) -> Maybe Pangraph +revert t = let + vf :: ProtoVertex -> VertexID + vf v = (fromJust . lookup "id") (protoVertexAttributes v) + ef :: ProtoEdge -> (VertexID, VertexID) + ef e = let + lookup' :: Value -> VertexID + lookup' value = (fromJust . lookup value) (protoEdgeAttributes e) + in (lookup' "source", lookup' "target") + in buildPangraph (FGL t) vf ef + +newtype FGL = FGL ([FGL.LNode ByteString], [FGL.LEdge Int]) + +instance BuildPangraph FGL where + getProtoVertex (FGL (ns, _)) = map (\n -> makeProtoVertex [("id", snd n)]) ns + getProtoEdge (FGL (_, es)) = let + ps :: Show a => a -> ByteString + ps = pack . show + -- Take the source and destination and construct the protoEdge + in map (\(src, dst, _) -> makeProtoEdge [("source", "n" <> ps src), ("target", "n" <> ps dst)]) es diff --git a/src/Pangraph/Gml/Parser.hs b/src/Pangraph/Gml/Parser.hs index 5bc4dec..040b933 100644 --- a/src/Pangraph/Gml/Parser.hs +++ b/src/Pangraph/Gml/Parser.hs @@ -61,12 +61,11 @@ gmlToPangraph gml = do let vertices = map snd (filter (\(k, _) -> k == "node") values) let edges = map snd (filter (\(k, _) -> k == "edge") values) let pVertices = mapMaybe gmlToVertex vertices - verticeGraph <- makePangraph pVertices [] - let pEdges = mapMaybe (gmlToEdge verticeGraph) edges + let pEdges = mapMaybe gmlToEdge edges makePangraph pVertices pEdges -gmlToEdge :: Pangraph -> Gml Text -> Maybe Edge -gmlToEdge graph gml = do +gmlToEdge :: Gml Text -> Maybe Edge +gmlToEdge gml = do sourceV <- lookupValue gml "source" targetV <- lookupValue gml "target" source <- integerValue sourceV @@ -74,9 +73,7 @@ gmlToEdge graph gml = do atts <- attrs gml let sourceB = encodeUtf8 (pack (show source)) let targetB = encodeUtf8 (pack (show target)) - sourceVertex <- lookupVertex sourceB graph - targetVertex <- lookupVertex targetB graph - return (makeEdge atts (sourceVertex, targetVertex)) + return (makeEdge (sourceB, targetB) atts) gmlToVertex :: Gml Text -> Maybe Vertex gmlToVertex gml = do @@ -147,4 +144,3 @@ stringParser = do whitespace :: Parser () whitespace = skip isHorizontalSpace <|> endOfLine - diff --git a/src/Pangraph/Gml/Writer.hs b/src/Pangraph/Gml/Writer.hs index 31fc7e9..7dd8799 100644 --- a/src/Pangraph/Gml/Writer.hs +++ b/src/Pangraph/Gml/Writer.hs @@ -48,17 +48,17 @@ gmlVertex :: Vertex -> (ByteString, Gml ByteString) gmlVertex vertex = let vId = read (unpack (vertexID vertex)) filteredAttrs = filter (\(key, _) -> key /= "id") (vertexAttributes vertex) - attrs = map (\(x, y) -> (x, String y)) (filteredAttrs) + attrs = map (\(x, y) -> (x, String y)) filteredAttrs in ("node", Object (("id", Integer vId):attrs)) gmlEdge :: Edge -> (ByteString, Gml ByteString) gmlEdge edge = let (source, target) = edgeEndpoints edge - sId = read (unpack (vertexID source)) - tId = read (unpack (vertexID target)) - filteredAttrs = filter (\(key, _) -> not (key `elem` ["source", "target"])) + sId = read (unpack source) + tId = read (unpack target) + filteredAttrs = filter (\(key, _) -> (key `notElem` ["source", "target"])) (edgeAttributes edge) - attrs = map (\(x, y) -> (x, String y)) (filteredAttrs) + attrs = map (\(x, y) -> (x, String y)) filteredAttrs in ("edge", Object (("source", Integer sId):("target", Integer tId):attrs)) -- | Serializes a 'Gml' syntax tree into a bytestring. diff --git a/src/Pangraph/GraphML/Parser.hs b/src/Pangraph/GraphML/Parser.hs index a917e6c..2475438 100644 --- a/src/Pangraph/GraphML/Parser.hs +++ b/src/Pangraph/GraphML/Parser.hs @@ -1,20 +1,27 @@ +{-| +Module : Pangraph.GraphML.Parser +Description : The parser for GraphML + +Provides two functions for constructing a `Pangraph` from a GraphML file. +-} module Pangraph.GraphML.Parser ( parse, unsafeParse ) where import Data.Maybe -import qualified Data.ByteString as BS -import qualified Pangraph as P -import qualified Text.XML.Hexml as H -import qualified Pangraph.Internal.XMLTemplate as PT +import Data.ByteString(ByteString) +import Pangraph +import qualified Pangraph.Internal.HexmlExtra as H +import qualified Pangraph.Internal.XMLTemplate as PT -- * Parsing --- | Returns 'Pangraph' if it can be parsed from a raw GraphML file. -parse :: BS.ByteString -> Maybe P.Pangraph -parse file = either (const Nothing) (PT.hexmlToPangraph PT.graphMLTemplate) (H.parse file) +-- | Throws on on failed XML parsing. +-- Otherwise returns 'Right Pangraph' if the graph is well formed, listing 'Left [MalformedEdge]' otherwise. +parse :: ByteString -> Maybe Pangraph +parse = PT.hexmlToPangraph PT.graphMLTemplate . H.hexmlParse --- | Like 'parse' except it throws an error on Nothing, which is when parsing fails. -unsafeParse :: BS.ByteString -> P.Pangraph -unsafeParse file = fromMaybe (error "Parse failed") (parse file) +-- | Like 'parse' except it throws an error on Nothing, which is when parsing fails OR the graph is malformed. +unsafeParse :: ByteString -> Pangraph +unsafeParse file = fromJust (error "Parse failed") (parse file) diff --git a/src/Pangraph/GraphML/Writer.hs b/src/Pangraph/GraphML/Writer.hs index c01b6b9..f756323 100644 --- a/src/Pangraph/GraphML/Writer.hs +++ b/src/Pangraph/GraphML/Writer.hs @@ -1,3 +1,9 @@ +{-| +Module : Pangraph.GraphML.Writer +Description : Serlize a `Pangraph` into a `ByteString` + +-} + {-# LANGUAGE OverloadedStrings #-} module Pangraph.GraphML.Writer diff --git a/src/Pangraph/Internal/HexmlExtra.hs b/src/Pangraph/Internal/HexmlExtra.hs new file mode 100644 index 0000000..a9b8d03 --- /dev/null +++ b/src/Pangraph/Internal/HexmlExtra.hs @@ -0,0 +1,28 @@ +module Pangraph.Internal.HexmlExtra where + +import Data.List (concatMap) +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. +followChildren :: Node -> [ByteString] -> [Node] +followChildren h [] = [h] +followChildren h bs = (concatMap recurse . childrenBy h) (head bs) + where + recurse :: Node -> [Node] + recurse n = followChildren n (tail bs) + +-- An unsafe version of the 'Text.XML.Hexml.parse' upon failure throws error to stderr. +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 a = (attributeName a, attributeValue a) + \ No newline at end of file diff --git a/src/Pangraph/Internal/ProtoGraph.hs b/src/Pangraph/Internal/ProtoGraph.hs new file mode 100644 index 0000000..5ec81e5 --- /dev/null +++ b/src/Pangraph/Internal/ProtoGraph.hs @@ -0,0 +1,93 @@ +{-| +Module : Pangraph.Internal.ProtoGraph +Description : Boilerplate for constructing Pangraphs + +This module provides common boilerplate +code which implements constructing a Pangraph from +either ASTs or Graph types. + +It is exported as internal for now as it is intended +use by modules which will not re-export it. +-} +{-# LANGUAGE OverloadedStrings #-} + + +module Pangraph.Internal.ProtoGraph + ( ProtoVertex() + , ProtoEdge() + , makeProtoVertex + , makeProtoEdge + , protoVertexAttributes + , protoEdgeAttributes + , BuildPangraph() + , buildPangraph + , getProtoEdge + , getProtoVertex + ) where + +import Pangraph + +class BuildPangraph t where + getProtoVertex :: t -> [ProtoVertex] + getProtoEdge :: t -> [ProtoEdge] + +newtype ProtoGraphStage1 = ProtoGraphStage1 (Maybe Pangraph) + deriving (Eq) + +newtype ProtoGraphStage2 = ProtoGraphStage2 (Maybe Pangraph) + deriving (Eq) + +newtype ProtoEdge = ProtoEdge [Attribute] + deriving (Eq) + +newtype ProtoVertex = ProtoVertex [Attribute] + deriving (Eq) + +instance Show ProtoVertex where + show (ProtoVertex as) = unwords ["makeProtoVertex", show as] + +instance Show ProtoEdge where + show (ProtoEdge as) = unwords ["makeProtoEdge", show as] + +-- | Given an Instance t of the BuildGraph will attempt to construct a Pangraph. +-- This can be used to avoid boilerplate code which is common many implementations. +buildPangraph :: BuildPangraph t => t -> (ProtoVertex -> VertexID) -> (ProtoEdge -> (VertexID, VertexID)) -> Maybe Pangraph +buildPangraph t vf ef = let + vs = getProtoVertex t + es = getProtoEdge t + stage1 = makeProtoGraphStage1 vs vf + (ProtoGraphStage2 p) = makeProtoGraphStage2 stage1 es ef + in p + +-- | Stage1 add nodes to a Graph. +makeProtoGraphStage1 :: [ProtoVertex] -> (ProtoVertex -> VertexID) -> ProtoGraphStage1 +makeProtoGraphStage1 vs f = let + vertices :: [Vertex] + vertices = map (toVertex f) vs + toVertex fv v = makeVertex (fv v) (protoVertexAttributes v) + in (ProtoGraphStage1 . (\ a -> makePangraph a [])) vertices + +-- | Stage2 add edges to the Graph and return the result. +makeProtoGraphStage2 :: ProtoGraphStage1 -> [ProtoEdge] -> (ProtoEdge -> (VertexID, VertexID)) -> ProtoGraphStage2 +makeProtoGraphStage2 (ProtoGraphStage1 p) protoEdges ef = let + es = map (toEdge ef) protoEdges + toEdge fe e = makeEdge (fe e) (protoEdgeAttributes e) + s2 = fmap vertexList p >>= \ vs -> makePangraph vs es + in ProtoGraphStage2 s2 + +-- | ProtoEdge constructor +makeProtoEdge :: [Attribute] -> ProtoEdge +makeProtoEdge = ProtoEdge + +-- | ProtoVertex constructor +makeProtoVertex :: [Attribute] -> ProtoVertex +makeProtoVertex = ProtoVertex + +-- | Returns [`Attribute`] of a `ProtoEdge` +protoEdgeAttributes :: ProtoEdge -> [Attribute] +protoEdgeAttributes (ProtoEdge as) = as + +-- | Returns [`Attribute`] of a `ProtoVertex` +protoVertexAttributes :: ProtoVertex -> [Attribute] +protoVertexAttributes (ProtoVertex as) = as + diff --git a/src/Pangraph/Internal/XMLTemplate.hs b/src/Pangraph/Internal/XMLTemplate.hs index d42ecbe..6b974b2 100644 --- a/src/Pangraph/Internal/XMLTemplate.hs +++ b/src/Pangraph/Internal/XMLTemplate.hs @@ -59,13 +59,13 @@ extractEdges:: [(P.VertexID, P.Vertex)] -> HexmlVertex -> EdgeRule -> [P.Edge] extractEdges verticesAssoc hexml (EdgeRule pe) = concatMap (makeEdge verticesAssoc hexml) pe makeEdge :: [(P.VertexID, P.Vertex)] -> HexmlVertex -> (Path, Element) -> [P.Edge] -makeEdge verticesAssoc hexml (path, element) = map (\as -> P.makeEdge as (getPrimitives as)) attList +makeEdge verticesAssoc hexml (path, element) = map (\as -> P.makeEdge (getPrimitives as) as) attList where - getPrimitives :: [P.Attribute] -> (P.Vertex, P.Vertex) + getPrimitives :: [P.Attribute] -> (P.VertexID, P.VertexID) getPrimitives list = case (lookup src list, lookup dst list) of (Just srcID, Just dstID) -> case (lookup srcID verticesAssoc, lookup dstID verticesAssoc) of - (Just vertexSrc, Just vertexDst) -> (vertexSrc, vertexDst) + (Just _, Just _) -> (srcID, dstID) _ -> error $ "Fatal: Edge endpoints are not vertices: " ++ show list _ -> error $ "Fatal: Edge endpoints not found in attribute list: " ++ show list attList :: [[P.Attribute]] diff --git a/stack.yaml b/stack.yaml index 20d5d77..ac1e54b 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,8 +1,8 @@ -extra-deps: -resolver: lts-11.8 +resolver: lts-12.9 flags: {} extra-package-dbs: [] packages: - '.' extra-deps: -- html-entities-1.1.4.2 +- html-entities-1.1.4.2 # For GML +- algebraic-graphs-0.1.1.1 \ No newline at end of file diff --git a/test/FGL.hs b/test/FGL.hs index 3b1329e..49e71cf 100644 --- a/test/FGL.hs +++ b/test/FGL.hs @@ -5,10 +5,13 @@ module FGL ( import Test.HUnit import Pangraph.Examples.SampleGraph(smallGraph) -import Pangraph.FGL(convert) +import Pangraph.FGL(convert, revert) fglTests :: [Test] -fglTests = [case1] +fglTests = [case1, case2] case1 :: Test -case1 = TestCase $ assertEqual "FGL Convert Case 1" "([(0,\"n0\"),(1,\"n1\"),(2,\"n2\")],[(0,2,0)])" (show . convert $ smallGraph) \ No newline at end of file +case1 = TestCase $ assertEqual "FGL Convert Case 1" "([(0,\"n0\"),(1,\"n1\"),(2,\"n2\")],[(0,2,0)])" (show . convert $ smallGraph) + +case2 :: Test +case2 = TestCase $ assertEqual "FGL Revert == Convert" (Just smallGraph) (revert . convert $ smallGraph) \ No newline at end of file diff --git a/test/Gml.hs b/test/Gml.hs index 15c064e..7ca5034 100644 --- a/test/Gml.hs +++ b/test/Gml.hs @@ -1,8 +1,11 @@ {-# LANGUAGE OverloadedStrings #-} + module Gml where import Test.HUnit +import Data.Maybe(fromJust) + import Pangraph import Pangraph.Gml.Ast import Pangraph.Gml.Parser @@ -26,7 +29,8 @@ pangraphConversion :: Test pangraphConversion = let file = "graph [node [id 1] node [id 2] edge [source 1 target 2]]" vertices = [makeVertex "1" [("id", "1")], makeVertex "2" [("id", "2")]] - edges = [makeEdge [("source", "1"), ("target", "2")] (vertices !! 0, vertices !! 1)] + [v1,v2] = map vertexID vertices + edges = [makeEdge (v1, v2) [("source", "1"), ("target", "2")] ] pangraph = makePangraph vertices edges in TestCase $ assertEqual "GML pangraphConversion" pangraph (parse file) @@ -48,23 +52,29 @@ testGmlWrite = let testPangraphWrite :: Test testPangraphWrite = let file = "graph [ node [ id 1] node [ id 2] edge [ source 1 target 2]]" - vertices = [makeVertex "1" [("id", "1")], makeVertex "2" [("id", "2")]] - edges = [makeEdge [("source", "1"), ("target", "2")] (vertices !! 0, vertices !! 1)] - Just pangraph = makePangraph vertices edges - in TestCase $ assertEqual "GML parseTest2" file (write pangraph) + in TestCase $ assertEqual "GML parseTest2" file (write gmlPangraphWrite) testHtmlEntitiesDecoding :: Test testHtmlEntitiesDecoding = let file = "graph [node [id 1 label \""Hello"\" ] node [id 2] edge [source 1 target 2]]" - vertices = [makeVertex "1" [("id", "1"), ("label", "\"Hello\"")], makeVertex "2" [("id", "2")]] - edges = [makeEdge [("source", "1"), ("target", "2")] (vertices !! 0, vertices !! 1)] - pangraph = makePangraph vertices edges - in TestCase $ assertEqual "GML testHtmlEntitiesDecoding" pangraph (parse file) + in TestCase $ assertEqual "GML testHtmlEntitiesDecoding" (Just gmlPangraph) (parse file) testHtmlEntitiesEncoding :: Test testHtmlEntitiesEncoding = let file = "graph [ node [ id 1 label \""Hello"\"] node [ id 2] edge [ source 1 target 2]]" + in TestCase $ assertEqual "GML testHtmlEntitiesEncoding" file (write gmlPangraph) + +gmlPangraph :: Pangraph +gmlPangraph = let vertices = [makeVertex "1" [("id", "1"), ("label", "\"Hello\"")], makeVertex "2" [("id", "2")]] - edges = [makeEdge [("source", "1"), ("target", "2")] (vertices !! 0, vertices !! 1)] - Just pangraph = makePangraph vertices edges - in TestCase $ assertEqual "GML testHtmlEntitiesEncoding" file (write pangraph) + [v1,v2] = map vertexID vertices + edges = [makeEdge (v1, v2) [("source", "1"), ("target", "2")]] + in fromJust $ makePangraph vertices edges + +gmlPangraphWrite :: Pangraph +gmlPangraphWrite = let + vertices = [makeVertex "1" [("id", "1")], makeVertex "2" [("id", "2")]] + [v1,v2] = map vertexID vertices + edges = [makeEdge (v1, v2) [("source", "1"), ("target", "2")]] + + in fromJust $ makePangraph vertices edges \ No newline at end of file diff --git a/test/GraphML.hs b/test/GraphML.hs index 55f9ca0..2463bcb 100644 --- a/test/GraphML.hs +++ b/test/GraphML.hs @@ -6,11 +6,10 @@ graphmlTests import Test.HUnit -import Data.Maybe - import Pangraph import Pangraph.GraphML.Parser import Pangraph.GraphML.Writer +import Pangraph.Examples.SampleGraph graphmlTests :: [Test] graphmlTests = [case1, case2] @@ -18,6 +17,7 @@ graphmlTests = [case1, case2] case1 :: Test case1 = let + file :: Maybe Pangraph file = parse " \ \\ \ \ \" - sampleVertices = [ - makeVertex "n0" [ ("id","n0")], - makeVertex "n1" [ ("id","n1")], - makeVertex "n2" [ ("id","n2")]] - graph = makePangraph sampleVertices - [makeEdge - [("source","n0"),("target","n2")] - (head sampleVertices, sampleVertices !! 2)] - in TestCase $ assertEqual "GraphML Parse case 1" (graph :: Maybe Pangraph) file + in TestCase $ assertEqual "GraphML Parse case 1" (Just smallGraph) file case2 :: Test -case2 = - let - sampleVertices = [ - makeVertex "n0" [ ("id","n0")], - makeVertex "n1" [ ("id","n1")], - makeVertex "n2" [ ("id","n2")]] - graph = makePangraph sampleVertices - [makeEdge - [("source","n0"),("target","n2")] - (head sampleVertices, sampleVertices !! 2)] - justGraph = fromMaybe (error "Sample graph failed to compile") graph - in TestCase $ assertEqual "GraphML Write case 1" (graph :: Maybe Pangraph) (parse $ write justGraph) +case2 = TestCase $ assertEqual "GraphML Write case 1" (Just smallGraph) (parse . write $ smallGraph) diff --git a/test/Show.hs b/test/Show.hs index 3d17918..ae24a68 100644 --- a/test/Show.hs +++ b/test/Show.hs @@ -4,10 +4,8 @@ module Show ( showTests ) where -import Data.Maybe import Test.HUnit -import Pangraph - +import Pangraph.Examples.SampleGraph showTests :: [Test] showTests = [case1] @@ -15,20 +13,11 @@ showTests = [case1] case1 :: Test case1 = let - literal = "makePangraph [makeVertex \"0\" \ - \[(\"id\",\"0\")],makeVertex \"1\" \ - \[(\"id\",\"1\")]] [makeEdge \ - \[(\"source\",\"0\"),(\"target\",\"1\")] \ - \(makeVertex \"0\" \ - \[(\"id\",\"0\")],makeVertex \"1\" [(\"id\",\"1\")])]" - sampleVertices = [makeVertex "0" [("id","0")] - ,makeVertex "1" [ ("id","1")]] - graph = show $ fromMaybe - (error "Sample graph failed to build") $ - makePangraph - sampleVertices [ - makeEdge - [("source","0"), ("target","1")] - (head sampleVertices, sampleVertices !! 1) - ] - in TestCase $ assertEqual "Show instance case 1" literal (graph :: String) + literal :: String + literal = + "makePangraph [makeVertex \"n0\" [(\"id\",\"n0\")]\ + \,makeVertex \"n1\" [(\"id\",\"n1\")],\ + \makeVertex \"n2\" [(\"id\",\"n2\")]] \ + \[makeEdge (\"n0\",\"n2\") \ + \[(\"source\",\"n0\"),(\"target\",\"n2\")]]" + in TestCase $ assertEqual "Show instance case 1" literal (show smallGraph)