packages feed

pangraph 0.1.2 → 0.2.0

raw patch · 20 files changed

+735/−122 lines, 20 filesdep +attoparsecdep +fgldep +html-entitiesdep ~algebraic-graphs

Dependencies added: attoparsec, fgl, html-entities, text

Dependency ranges changed: algebraic-graphs

Files

pangraph.cabal view
@@ -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+
src/Pangraph.hs view
@@ -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'
src/Pangraph/Containers.hs view
@@ -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
+ src/Pangraph/Examples/Gml.hs view
@@ -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)
src/Pangraph/Examples/SampleGraph.hs view
@@ -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")]]
+ src/Pangraph/FGL.hs view
@@ -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
+ src/Pangraph/Gml/Ast.hs view
@@ -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: +<http://www.fim.uni-passau.de/fileadmin/files/lehrstuhl/brandenburg/projekte/gml/gml-technical-report.pdf>.+-}+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)
+ src/Pangraph/Gml/Parser.hs view
@@ -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:+<http://www.fim.uni-passau.de/fileadmin/files/lehrstuhl/brandenburg/projekte/gml/gml-technical-report.pdf>.++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
+ src/Pangraph/Gml/Writer.hs view
@@ -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 +<http://www.fim.uni-passau.de/fileadmin/files/lehrstuhl/brandenburg/projekte/gml/gml-technical-report.pdf>+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)
src/Pangraph/GraphML/Parser.hs view
@@ -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)
src/Pangraph/GraphML/Writer.hs view
@@ -1,3 +1,9 @@+{-|+Module          : Pangraph.GraphML.Writer+Description     : Serlize a `Pangraph` into a `ByteString`++-}+ {-# LANGUAGE OverloadedStrings #-}  module Pangraph.GraphML.Writer
+ src/Pangraph/Internal/HexmlExtra.hs view
@@ -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)+
+ src/Pangraph/Internal/ProtoGraph.hs view
@@ -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+
src/Pangraph/Internal/XMLTemplate.hs view
@@ -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]]
+ test/FGL.hs view
@@ -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)
+ test/Gml.hs view
@@ -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 \"&quot;Hello&quot;\" ] 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 \"&quot;Hello&quot;\"] 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
test/GraphML.hs view
@@ -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 "<?xml version=\"1.0\" encoding=\"UTF-8\"?> \             \<graphml xmlns=\"http://graphml.graphdrawing.org/xmlns\"\             \    xmlns:xsi=\"http://www.w3.org/2001/XMLSchema-instance\"\@@ -30,26 +30,7 @@             \    <edge id=\"e1\" source=\"n0\" target=\"n2\"/>\             \    </graph>\             \</graphml>"-    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)
test/Main.hs view
@@ -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]
test/Show.hs view
@@ -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)
+ test/TestPangraph.hs view
@@ -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)