diff --git a/pangraph.cabal b/pangraph.cabal --- 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 @@ -22,18 +22,29 @@ hs-source-dirs: src exposed-modules: Pangraph , Pangraph.Containers + , Pangraph.FGL , 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 + , Pangraph.Gml.Writer build-depends: base >= 4.8 && < 5 , bytestring , hexml , containers - , algebraic-graphs == 0.1.1.* + , algebraic-graphs + , fgl + , attoparsec + , text + , html-entities default-language: Haskell2010 GHC-options: -Wall -fwarn-tabs @@ -41,13 +52,17 @@ type: exitcode-stdio-1.0 hs-source-dirs: test main-is: Main.hs - other-modules: Show + other-modules: Containers + , FGL , GraphML - , Containers + , Show + , TestPangraph + , Gml build-depends: base >= 4.8 && < 5 - , pangraph + , containers , bytestring , HUnit - , containers + , pangraph default-language: Haskell2010 GHC-options: -Wall -fwarn-tabs -fbreak-on-exception + diff --git a/src/Pangraph.hs b/src/Pangraph.hs --- 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 @@ -- | 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 @@ -- | 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 = 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 --- 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 diff --git a/src/Pangraph/Examples/Gml.hs b/src/Pangraph/Examples/Gml.hs new file mode 100644 --- /dev/null +++ b/src/Pangraph/Examples/Gml.hs @@ -0,0 +1,13 @@ +module Pangraph.Examples.Gml where + +import Prelude hiding (readFile) + +import Data.ByteString (readFile) + +import qualified Pangraph.Gml.Parser as Gml + +main :: IO () +main = do + fileName <- getLine + file <- readFile fileName + print (Gml.parse file) diff --git a/src/Pangraph/Examples/SampleGraph.hs b/src/Pangraph/Examples/SampleGraph.hs --- a/src/Pangraph/Examples/SampleGraph.hs +++ b/src/Pangraph/Examples/SampleGraph.hs @@ -5,17 +5,15 @@ ) 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 new file mode 100644 --- /dev/null +++ b/src/Pangraph/FGL.hs @@ -0,0 +1,75 @@ +{- +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 + +-- 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 :: 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 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/Ast.hs b/src/Pangraph/Gml/Ast.hs new file mode 100644 --- /dev/null +++ b/src/Pangraph/Gml/Ast.hs @@ -0,0 +1,59 @@ +{-| +Module : Pangraph.Gml.Ast +Description : AST for gml files + +AST for gml (Graph Modelling Language) files. The specification of the gml +format can be found at: +. +-} +module Pangraph.Gml.Ast where + +-- | Type of a AST node. +-- 'k' is the type that is used to represent strings. +data Gml k + -- | Integer value + = Integer Integer + -- | Floating point value + | Float Double + -- | String value + | String k + -- | Object value. A gml object is a list of named values. The names of the + -- values are not necessarily unique! + | Object [(k, Gml k)] deriving (Show, Eq, Ord) + +-- | Looks up a value in the given gml object. +-- Produces 'Nothing' when the given value is not a gml object or the object +-- doesn't contain the a value with the given name. If a object contains +-- multiple values with the same name one the values is returned. +lookupValue :: Eq k => Gml k -> k -> Maybe (Gml k) +lookupValue (Object values) key = lookup key values +lookupValue _ _ = Nothing + +-- | If the given gml value is a integer produces the integer value. +integerValue :: Gml k -> Maybe Integer +integerValue (Integer v) = Just v +integerValue _ = Nothing + +-- | If the given gml value is a double value produces the float value. +floatValue :: Gml k -> Maybe Double +floatValue (Float v) = Just v +floatValue _ = Nothing + +-- | If the given gml value is a string produces the string value. +stringValue :: Gml k -> Maybe k +stringValue (String v) = Just v +stringValue _ = Nothing + +-- | If the given gml value is an object produces the list of values that the +-- object contains. +objectValues :: Gml k -> Maybe [(k, Gml k)] +objectValues (Object values) = Just values +objectValues _ = Nothing + +-- | Maps all strings in the gml ast. +mapStrings :: (a -> b) -> Gml a -> Gml b +mapStrings f (Object attrs) = (Object + (map (\(k, v) -> (f k, mapStrings f v)) attrs)) +mapStrings f (String s) = (String (f s)) +mapStrings _ (Integer i) = (Integer i) +mapStrings _ (Float f) = (Float f) diff --git a/src/Pangraph/Gml/Parser.hs b/src/Pangraph/Gml/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Pangraph/Gml/Parser.hs @@ -0,0 +1,146 @@ +{-# LANGUAGE OverloadedStrings #-} +{-| +Module : Pangraph.Gml.Parser +Description : Parse gml files + +Functions for parseing gml (Graphical Modelling Language) files. +A gml specification can be found at: +. + +This follows the specification except for two cases: + + 1. All files are assumed to be encoded in UTF8 + + 2. The line length limit is ignored. +-} +module Pangraph.Gml.Parser (parse, parseGml, decode, gmlToPangraph) where + +import Data.Attoparsec.Text hiding (parse) +import Data.Attoparsec.Combinator (lookAhead) +import Data.Text (Text, cons, pack, lines, unlines, isPrefixOf) +import Data.Text.Encoding (decodeUtf8, encodeUtf8) +import Data.Text.Lazy.Builder (toLazyText) +import Data.Text.Lazy (toStrict) +import Control.Applicative ((<|>), (<*)) +import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as BC +import Data.Maybe +import HTMLEntities.Decoder (htmlEncodedText) +import Prelude hiding (takeWhile, id, lines, unlines) + +import Pangraph +import Pangraph.Gml.Ast + +-- | Parses the 'ByteString' into a 'Pangraph'. +parse :: B.ByteString -> Maybe Pangraph +parse contents = fmap decode (parseGml contents) >>= gmlToPangraph + +-- | Parses the 'ByteString' into a 'Gml' ast. The function doesn't decode +-- special characters inside strings. To decode special characters inside strings +-- use the 'decode' function. +parseGml :: B.ByteString -> Maybe (Gml Text) +parseGml contents = either (const Nothing) Just + (parseText (decodeUtf8 contents)) + +parseText :: Text -> Either String (Gml Text) +parseText = parseOnly (gmlParser <* endOfInput) . removeComments + +-- | Decodes special characters inside gml strings. +decode :: Gml Text -> Gml Text +decode = mapStrings (toStrict . toLazyText . htmlEncodedText) + +removeComments :: Text -> Text +removeComments text = unlines (filter (not . isPrefixOf "#") (lines text)) + +-- | Converts a gml ast into a 'Pangraph'. If a node/edge contains a gml object +-- these object are not contained in the resulting 'Pangraph'. +gmlToPangraph :: Gml Text -> Maybe Pangraph +gmlToPangraph gml = do + graphObj <- lookupValue gml "graph" + values <- objectValues graphObj + let vertices = map snd (filter (\(k, _) -> k == "node") values) + let edges = map snd (filter (\(k, _) -> k == "edge") values) + let pVertices = mapMaybe gmlToVertex vertices + let pEdges = mapMaybe gmlToEdge edges + makePangraph pVertices pEdges + +gmlToEdge :: Gml Text -> Maybe Edge +gmlToEdge gml = do + sourceV <- lookupValue gml "source" + targetV <- lookupValue gml "target" + source <- integerValue sourceV + target <- integerValue targetV + atts <- attrs gml + let sourceB = encodeUtf8 (pack (show source)) + let targetB = encodeUtf8 (pack (show target)) + return (makeEdge (sourceB, targetB) atts) + +gmlToVertex :: Gml Text -> Maybe Vertex +gmlToVertex gml = do + idV <- lookupValue gml "id" + id <- integerValue idV + atts <- attrs gml + let bid = BC.pack (show id) + return (makeVertex bid atts) + +attrs :: Gml Text -> Maybe [(B.ByteString, B.ByteString)] +attrs gml = mapMaybe convertValue <$> objectValues gml + +convertValue :: (Text, Gml Text) -> Maybe (B.ByteString, B.ByteString) +convertValue (k, Integer i) = Just (encodeUtf8 k, BC.pack (show i)) +convertValue (k, Float d) = Just (encodeUtf8 k, BC.pack (show d)) +convertValue (k, String s) = Just (encodeUtf8 k, encodeUtf8 s) +convertValue _ = Nothing + +gmlParser :: Parser (Gml Text) +gmlParser = innerListParser + +listParser :: Parser (Gml Text) +listParser = do + skipSpace + skip (inClass "[") + obj <- innerListParser + skipSpace + skip (inClass "]") + skipSpace + return obj + +innerListParser :: Parser (Gml Text) +innerListParser = Object <$> many' listEntryParser + +listEntryParser :: Parser (Text, Gml Text) +listEntryParser = do + skipSpace + name <- key + skipMany1 whitespace + value <- valueParser + return (name, value) + +key :: Parser Text +key = do + start <- satisfy (inClass "a-zA-Z") + rest <- takeWhile (inClass "a-zA-Z0-9") + return (start `cons` rest) + +valueParser :: Parser (Gml Text) +valueParser = stringParser <|> integerParser <|> floatParser <|> listParser + +integerParser :: Parser (Gml Text) +integerParser = do + i <- signed decimal + _ <- lookAhead (notChar '.') + return (Integer i) + +floatParser :: Parser (Gml Text) +floatParser = Float <$> double + +stringParser :: Parser (Gml Text) +stringParser = do + let del = inClass "\"" + skip del + s <- takeTill del + skip del + return (String s) + +whitespace :: Parser () +whitespace = skip isHorizontalSpace <|> endOfLine diff --git a/src/Pangraph/Gml/Writer.hs b/src/Pangraph/Gml/Writer.hs new file mode 100644 --- /dev/null +++ b/src/Pangraph/Gml/Writer.hs @@ -0,0 +1,77 @@ +{-# LANGUAGE OverloadedStrings #-} +{-| +Module : Pangraph.Gml.Writer +Description : Functions for writing gml files + +Functions for writing gml files. Follows the gml specification at + +execpt for two cases: + + 1. all produced 'ByteString's are encoded in UTF8 instead of ASCII, + + 2. the line length limit is ignored. + -} +module Pangraph.Gml.Writer (writeGml, pangraphToGml, write, encodeStrings) where + +import HTMLEntities.Text (text) +import Data.ByteString (ByteString, concat) +import Data.ByteString.Char8 (unpack, pack) +import Data.Text.Encoding (encodeUtf8, decodeUtf8) + +import Prelude hiding (concat) + +import Pangraph +import Pangraph.Gml.Ast + +-- | Serializes a Pangraph into a GML file. +write :: Pangraph -> ByteString +write graph = let + gml = pangraphToGml graph + Just bs = writeGml gml + in bs + +-- | Converts a 'Pangraph' into a 'Gml' syntax tree. +-- Automatically encodes special characters in strings. +pangraphToGml :: Pangraph -> Gml ByteString +pangraphToGml graph = let + vertices = vertexList graph + edges = edgeList graph + gmlVertices = map gmlVertex vertices + gmlEdges = map gmlEdge edges + in encodeStrings (Object [("graph", Object (gmlVertices ++ gmlEdges))]) + +-- | Encodes the string values in a 'Gml' syntax tree. +encodeStrings :: Gml ByteString -> Gml ByteString +encodeStrings = mapStrings (encodeUtf8 . text . decodeUtf8) + +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 + in ("node", Object (("id", Integer vId):attrs)) + +gmlEdge :: Edge -> (ByteString, Gml ByteString) +gmlEdge edge = let + (source, target) = edgeEndpoints edge + 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 + in ("edge", Object (("source", Integer sId):("target", Integer tId):attrs)) + +-- | Serializes a 'Gml' syntax tree into a bytestring. +-- Produces 'Nothing' for all values except 'Object' since a gml file +-- must contain at least one top level object to hold all values. +writeGml :: Gml ByteString -> Maybe ByteString +writeGml (Object values) = Just $ concat ( + (map (\(key, value) -> concat [key, " ", writeGml' value]) values)) +writeGml _ = Nothing + +writeGml' :: Gml ByteString -> ByteString +writeGml' (Object values) = concat ( ["["] ++ + (map (\(key, value) -> concat [" ", key, " ", writeGml' value]) values) ++ ["]"]) +writeGml' (String s) = concat ["\"", s , "\""] +writeGml' (Float d) = pack (show d) +writeGml' (Integer i) = pack (show i) diff --git a/src/Pangraph/GraphML/Parser.hs b/src/Pangraph/GraphML/Parser.hs --- 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 --- 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 --- /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) + diff --git a/src/Pangraph/Internal/ProtoGraph.hs b/src/Pangraph/Internal/ProtoGraph.hs new file mode 100644 --- /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 --- a/src/Pangraph/Internal/XMLTemplate.hs +++ b/src/Pangraph/Internal/XMLTemplate.hs @@ -59,13 +59,13 @@ 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/test/FGL.hs b/test/FGL.hs new file mode 100644 --- /dev/null +++ b/test/FGL.hs @@ -0,0 +1,17 @@ +module FGL ( + fglTests + ) where + +import Test.HUnit + +import Pangraph.Examples.SampleGraph(smallGraph) +import Pangraph.FGL(convert, revert) + +fglTests :: [Test] +fglTests = [case1, case2] + +case1 :: Test +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) diff --git a/test/Gml.hs b/test/Gml.hs new file mode 100644 --- /dev/null +++ b/test/Gml.hs @@ -0,0 +1,80 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Gml where + +import Test.HUnit + +import Data.Maybe(fromJust) + +import Pangraph +import Pangraph.Gml.Ast +import Pangraph.Gml.Parser +import Pangraph.Gml.Writer + +gmlTests :: [Test] +gmlTests = [testGmlParse, pangraphConversion, testComments, testGmlWrite, + testPangraphWrite, testHtmlEntitiesDecoding, testHtmlEntitiesEncoding] + +testGmlParse :: Test +testGmlParse = let + file = "graph [node [id 1 label \"Hello\"] node [id 2] edge [source 1 target 2]]" + graph = Just (Object [("graph", Object [ + ("node", Object [("id", Integer 1), ("label", String "Hello")]), + ("node", Object [("id", Integer 2)]), + ("edge", Object [("source", Integer 1), + ("target", Integer 2)])])]) + in TestCase $ assertEqual "GML parseTest1" graph (parseGml file) + +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")]] + [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) + +testComments :: Test +testComments = let + file = "#test" + graph = Just (Object []) + in TestCase $ assertEqual "GML testComments" graph (parseGml file) + +testGmlWrite :: Test +testGmlWrite = let + graph = (Object [("graph", Object [("node", Object [("id", Integer 1)]), + ("node", Object [("id", Integer 2)]), + ("edge", Object [("source", Integer 1), + ("target", Integer 2)])])]) + file = Just "graph [ node [ id 1] node [ id 2] edge [ source 1 target 2]]" + in TestCase $ assertEqual "GML testWriteGML" file (writeGml graph) + +testPangraphWrite :: Test +testPangraphWrite = let + file = "graph [ node [ id 1] node [ id 2] edge [ source 1 target 2]]" + 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]]" + 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")]] + [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 diff --git a/test/GraphML.hs b/test/GraphML.hs --- a/test/GraphML.hs +++ b/test/GraphML.hs @@ -6,11 +6,10 @@ 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 @@ 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/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -3,8 +3,11 @@ import GraphML import Show import Containers +import TestPangraph +import FGL +import Gml import Test.HUnit main :: IO Counts -main = runTestTT $ TestList $ concat [graphmlTests, showTests, containersTests] +main = (runTestTT . TestList . concat) [containersTests, fglTests, graphmlTests, showTests, pangraphTests, gmlTests] diff --git a/test/Show.hs b/test/Show.hs --- a/test/Show.hs +++ b/test/Show.hs @@ -4,10 +4,8 @@ showTests ) where -import Data.Maybe import Test.HUnit -import Pangraph - +import Pangraph.Examples.SampleGraph showTests :: [Test] showTests = [case1] @@ -15,20 +13,11 @@ 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) diff --git a/test/TestPangraph.hs b/test/TestPangraph.hs new file mode 100644 --- /dev/null +++ b/test/TestPangraph.hs @@ -0,0 +1,19 @@ +module TestPangraph ( + pangraphTests +) where + +import Test.HUnit +import Pangraph +import Pangraph.Examples.SampleGraph(smallGraph) + +import Data.Maybe(mapMaybe) + +pangraphTests :: [Test] +pangraphTests = [pangraphCases] + +pangraphCases :: Test +pangraphCases = + let + graph = (length . mapMaybe edgeID) (edgeList smallGraph) + graphEdgeNo = (length . edgeList) smallGraph + in TestCase $ assertEqual "Edges have \"Just Edge ID\" case 1" graphEdgeNo (graph :: Int)