{-# language OverloadedStrings #-}
{-# options_ghc -Wno-unused-imports #-}
-- | Mostly-complete implementation of the GML format
--
-- https://en.wikipedia.org/wiki/Graph_Modelling_Language
module Algebra.Graph.IO.GML (gmlGraph, gmlGraphP, GMLGraph(..), GMLNode(..), GMLEdge(..)) where

import Control.Applicative hiding (many, some)
import Data.Char (isAlpha, isSpace)
import Data.Functor (void)
import Data.Void (Void)

-- algebraic-graphs
import qualified Algebra.Graph as G (Graph, empty, vertex, edge, overlay)
-- megaparsec
import Text.Megaparsec (Parsec, parse, parseTest, satisfy, (<?>))
import Text.Megaparsec.Char (space1)
import qualified Text.Megaparsec.Char.Lexer as L
-- parser-combinators
import Control.Monad.Combinators (many, some, between, skipManyTill)
-- text
import Data.Text (Text)
import Data.Text.IO (readFile)

import Prelude hiding (readFile, takeWhile)

import Algebra.Graph.IO.Internal.Megaparsec (Parser, lexeme, symbol, anyString)

-- | Construct a 'G.Graph' using the edge data contained in a 'GMLGraph'
gmlGraph :: GMLGraph a b -> G.Graph a
gmlGraph :: GMLGraph a b -> Graph a
gmlGraph (GMLGraph Maybe String
_ [GMLNode a]
_ [GMLEdge a b]
es) =
  (Graph a -> GMLEdge a b -> Graph a)
-> Graph a -> [GMLEdge a b] -> Graph a
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\Graph a
gr (GMLEdge a
a a
b Maybe b
_ Maybe String
_) -> a -> a -> Graph a
forall a. a -> a -> Graph a
G.edge a
a a
b Graph a -> Graph a -> Graph a
forall a. Graph a -> Graph a -> Graph a
`G.overlay` Graph a
gr) Graph a
forall a. Graph a
G.empty [GMLEdge a b]
es

-- | Graph entities of the GML graph format
data GMLGraph a b = GMLGraph {
  GMLGraph a b -> Maybe String
gmlHeader :: Maybe String
  , GMLGraph a b -> [GMLNode a]
gmlNodes :: [GMLNode a]
  , GMLGraph a b -> [GMLEdge a b]
gmlEdges :: [GMLEdge a b]
  } deriving (Int -> GMLGraph a b -> ShowS
[GMLGraph a b] -> ShowS
GMLGraph a b -> String
(Int -> GMLGraph a b -> ShowS)
-> (GMLGraph a b -> String)
-> ([GMLGraph a b] -> ShowS)
-> Show (GMLGraph a b)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall a b. (Show a, Show b) => Int -> GMLGraph a b -> ShowS
forall a b. (Show a, Show b) => [GMLGraph a b] -> ShowS
forall a b. (Show a, Show b) => GMLGraph a b -> String
showList :: [GMLGraph a b] -> ShowS
$cshowList :: forall a b. (Show a, Show b) => [GMLGraph a b] -> ShowS
show :: GMLGraph a b -> String
$cshow :: forall a b. (Show a, Show b) => GMLGraph a b -> String
showsPrec :: Int -> GMLGraph a b -> ShowS
$cshowsPrec :: forall a b. (Show a, Show b) => Int -> GMLGraph a b -> ShowS
Show)

-- | Parser for the GML graph format
gmlGraphP :: Parser a -- ^ parser for node id's
          -> Parser b
          -> Parser (GMLGraph a b)
gmlGraphP :: Parser a -> Parser b -> Parser (GMLGraph a b)
gmlGraphP Parser a
p Parser b
p2 = do
  Maybe String
header <- ParsecT Void Text Identity String
-> ParsecT Void Text Identity (Maybe String)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional ParsecT Void Text Identity String
creator -- header
  ParsecT Void Text Identity Text -> ParsecT Void Text Identity ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ParsecT Void Text Identity Text -> ParsecT Void Text Identity ())
-> ParsecT Void Text Identity Text -> ParsecT Void Text Identity ()
forall a b. (a -> b) -> a -> b
$ Text -> ParsecT Void Text Identity Text
symbol Text
"graph"
  Parser (GMLGraph a b) -> Parser (GMLGraph a b)
forall a. Parser a -> Parser a
sqBkts (Parser (GMLGraph a b) -> Parser (GMLGraph a b))
-> Parser (GMLGraph a b) -> Parser (GMLGraph a b)
forall a b. (a -> b) -> a -> b
$ do
    [GMLNode a]
ns <- ParsecT Void Text Identity (GMLNode a)
-> ParsecT Void Text Identity [GMLNode a]
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many (ParsecT Void Text Identity (GMLNode a)
 -> ParsecT Void Text Identity [GMLNode a])
-> ParsecT Void Text Identity (GMLNode a)
-> ParsecT Void Text Identity [GMLNode a]
forall a b. (a -> b) -> a -> b
$ Parser a -> ParsecT Void Text Identity (GMLNode a)
forall a. Parser a -> Parser (GMLNode a)
gmlNode Parser a
p
    [GMLEdge a b]
es <- ParsecT Void Text Identity (GMLEdge a b)
-> ParsecT Void Text Identity [GMLEdge a b]
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many (ParsecT Void Text Identity (GMLEdge a b)
 -> ParsecT Void Text Identity [GMLEdge a b])
-> ParsecT Void Text Identity (GMLEdge a b)
-> ParsecT Void Text Identity [GMLEdge a b]
forall a b. (a -> b) -> a -> b
$ Parser a -> Parser b -> ParsecT Void Text Identity (GMLEdge a b)
forall a b. Parser a -> Parser b -> Parser (GMLEdge a b)
gmlEdge Parser a
p Parser b
p2
    GMLGraph a b -> Parser (GMLGraph a b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (GMLGraph a b -> Parser (GMLGraph a b))
-> GMLGraph a b -> Parser (GMLGraph a b)
forall a b. (a -> b) -> a -> b
$ Maybe String -> [GMLNode a] -> [GMLEdge a b] -> GMLGraph a b
forall a b.
Maybe String -> [GMLNode a] -> [GMLEdge a b] -> GMLGraph a b
GMLGraph Maybe String
header [GMLNode a]
ns [GMLEdge a b]
es

creator :: Parser String
creator :: ParsecT Void Text Identity String
creator = do
  ParsecT Void Text Identity Text -> ParsecT Void Text Identity ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ParsecT Void Text Identity Text -> ParsecT Void Text Identity ())
-> ParsecT Void Text Identity Text -> ParsecT Void Text Identity ()
forall a b. (a -> b) -> a -> b
$ Text -> ParsecT Void Text Identity Text
symbol Text
"Creator"
  ParsecT Void Text Identity String
-> ParsecT Void Text Identity String
forall a. Parser a -> Parser a
quoted (ParsecT Void Text Identity String
 -> ParsecT Void Text Identity String)
-> ParsecT Void Text Identity String
-> ParsecT Void Text Identity String
forall a b. (a -> b) -> a -> b
$ ParsecT Void Text Identity Char
-> ParsecT Void Text Identity String
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many (ParsecT Void Text Identity Char
 -> ParsecT Void Text Identity String)
-> ParsecT Void Text Identity Char
-> ParsecT Void Text Identity String
forall a b. (a -> b) -> a -> b
$ (Token Text -> Bool) -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
(Token s -> Bool) -> m (Token s)
satisfy (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\"')

-- | GML nodes
data GMLNode a = GMLNode a (Maybe String) deriving (Int -> GMLNode a -> ShowS
[GMLNode a] -> ShowS
GMLNode a -> String
(Int -> GMLNode a -> ShowS)
-> (GMLNode a -> String)
-> ([GMLNode a] -> ShowS)
-> Show (GMLNode a)
forall a. Show a => Int -> GMLNode a -> ShowS
forall a. Show a => [GMLNode a] -> ShowS
forall a. Show a => GMLNode a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [GMLNode a] -> ShowS
$cshowList :: forall a. Show a => [GMLNode a] -> ShowS
show :: GMLNode a -> String
$cshow :: forall a. Show a => GMLNode a -> String
showsPrec :: Int -> GMLNode a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> GMLNode a -> ShowS
Show)

gmlNode :: Parser a -> Parser (GMLNode a)
gmlNode :: Parser a -> Parser (GMLNode a)
gmlNode Parser a
p = do
  ParsecT Void Text Identity Text -> ParsecT Void Text Identity ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ParsecT Void Text Identity Text -> ParsecT Void Text Identity ())
-> ParsecT Void Text Identity Text -> ParsecT Void Text Identity ()
forall a b. (a -> b) -> a -> b
$ Text -> ParsecT Void Text Identity Text
symbol Text
"node"
  Parser (GMLNode a) -> Parser (GMLNode a)
forall a. Parser a -> Parser a
sqBkts (Parser (GMLNode a) -> Parser (GMLNode a))
-> Parser (GMLNode a) -> Parser (GMLNode a)
forall a b. (a -> b) -> a -> b
$ do
    a
n <- Text -> ParsecT Void Text Identity Text
symbol Text
"id" ParsecT Void Text Identity Text -> Parser a -> Parser a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser a -> Parser a
forall a. Parser a -> Parser a
lexeme Parser a
p
    Maybe String
l <- ParsecT Void Text Identity String
-> ParsecT Void Text Identity (Maybe String)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional ParsecT Void Text Identity String
gmlLabel
    GMLNode a -> Parser (GMLNode a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (GMLNode a -> Parser (GMLNode a))
-> GMLNode a -> Parser (GMLNode a)
forall a b. (a -> b) -> a -> b
$ a -> Maybe String -> GMLNode a
forall a. a -> Maybe String -> GMLNode a
GMLNode a
n Maybe String
l

sqBkts :: Parser a -> Parser a
sqBkts :: Parser a -> Parser a
sqBkts = ParsecT Void Text Identity Text
-> ParsecT Void Text Identity Text -> Parser a -> Parser a
forall (m :: * -> *) open close a.
Applicative m =>
m open -> m close -> m a -> m a
between (Text -> ParsecT Void Text Identity Text
symbol Text
"[") (Text -> ParsecT Void Text Identity Text
symbol Text
"]")
quoted :: Parser a -> Parser a
quoted :: Parser a -> Parser a
quoted = ParsecT Void Text Identity Text
-> ParsecT Void Text Identity Text -> Parser a -> Parser a
forall (m :: * -> *) open close a.
Applicative m =>
m open -> m close -> m a -> m a
between (Text -> ParsecT Void Text Identity Text
symbol Text
"\"") (Text -> ParsecT Void Text Identity Text
symbol Text
"\"")

-- | GML edges
data GMLEdge a b = GMLEdge a a (Maybe b) (Maybe String) deriving (Int -> GMLEdge a b -> ShowS
[GMLEdge a b] -> ShowS
GMLEdge a b -> String
(Int -> GMLEdge a b -> ShowS)
-> (GMLEdge a b -> String)
-> ([GMLEdge a b] -> ShowS)
-> Show (GMLEdge a b)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall a b. (Show a, Show b) => Int -> GMLEdge a b -> ShowS
forall a b. (Show a, Show b) => [GMLEdge a b] -> ShowS
forall a b. (Show a, Show b) => GMLEdge a b -> String
showList :: [GMLEdge a b] -> ShowS
$cshowList :: forall a b. (Show a, Show b) => [GMLEdge a b] -> ShowS
show :: GMLEdge a b -> String
$cshow :: forall a b. (Show a, Show b) => GMLEdge a b -> String
showsPrec :: Int -> GMLEdge a b -> ShowS
$cshowsPrec :: forall a b. (Show a, Show b) => Int -> GMLEdge a b -> ShowS
Show)

gmlEdge :: Parser a -> Parser b -> Parser (GMLEdge a b)
gmlEdge :: Parser a -> Parser b -> Parser (GMLEdge a b)
gmlEdge Parser a
pa Parser b
pb = do
  ParsecT Void Text Identity Text -> ParsecT Void Text Identity ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ParsecT Void Text Identity Text -> ParsecT Void Text Identity ())
-> ParsecT Void Text Identity Text -> ParsecT Void Text Identity ()
forall a b. (a -> b) -> a -> b
$ Text -> ParsecT Void Text Identity Text
symbol Text
"edge"
  Parser (GMLEdge a b) -> Parser (GMLEdge a b)
forall a. Parser a -> Parser a
sqBkts (Parser (GMLEdge a b) -> Parser (GMLEdge a b))
-> Parser (GMLEdge a b) -> Parser (GMLEdge a b)
forall a b. (a -> b) -> a -> b
$ do
    a
a <- Parser a -> Parser a
forall a. Parser a -> Parser a
source Parser a
pa
    a
b <- Parser a -> Parser a
forall a. Parser a -> Parser a
target Parser a
pa
    Maybe b
v <- Parser b -> ParsecT Void Text Identity (Maybe b)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (Parser b -> Parser b
forall a. Parser a -> Parser a
value Parser b
pb)
    Maybe String
l <- ParsecT Void Text Identity String
-> ParsecT Void Text Identity (Maybe String)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional ParsecT Void Text Identity String
gmlLabel
    GMLEdge a b -> Parser (GMLEdge a b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (GMLEdge a b -> Parser (GMLEdge a b))
-> GMLEdge a b -> Parser (GMLEdge a b)
forall a b. (a -> b) -> a -> b
$ a -> a -> Maybe b -> Maybe String -> GMLEdge a b
forall a b. a -> a -> Maybe b -> Maybe String -> GMLEdge a b
GMLEdge a
a a
b Maybe b
v Maybe String
l

-- attributes

source, target, value :: Parser a -> Parser a
source :: Parser a -> Parser a
source = Text -> Parser a -> Parser a
forall a. Text -> Parser a -> Parser a
attr Text
"source"
target :: Parser a -> Parser a
target = Text -> Parser a -> Parser a
forall a. Text -> Parser a -> Parser a
attr Text
"target"
value :: Parser a -> Parser a
value = Text -> Parser a -> Parser a
forall a. Text -> Parser a -> Parser a
attr Text
"value"

gmlLabel :: Parser String
gmlLabel :: ParsecT Void Text Identity String
gmlLabel = Text -> ParsecT Void Text Identity Text
symbol Text
"label" ParsecT Void Text Identity Text
-> ParsecT Void Text Identity String
-> ParsecT Void Text Identity String
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT Void Text Identity String
-> ParsecT Void Text Identity String
forall a. Parser a -> Parser a
lexeme (ParsecT Void Text Identity String
-> ParsecT Void Text Identity String
forall a. Parser a -> Parser a
quoted ParsecT Void Text Identity String
p)
  where
    p :: ParsecT Void Text Identity String
p = ParsecT Void Text Identity Char
-> ParsecT Void Text Identity String
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many (ParsecT Void Text Identity Char
 -> ParsecT Void Text Identity String)
-> ParsecT Void Text Identity Char
-> ParsecT Void Text Identity String
forall a b. (a -> b) -> a -> b
$ (Token Text -> Bool) -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
(Token s -> Bool) -> m (Token s)
satisfy (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\"')

attr :: Text -> Parser a -> Parser a
attr :: Text -> Parser a -> Parser a
attr Text
str Parser a
p = Text -> ParsecT Void Text Identity Text
symbol Text
str ParsecT Void Text Identity Text -> Parser a -> Parser a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser a -> Parser a
forall a. Parser a -> Parser a
lexeme Parser a
p


-- gmlValue :: Parser a -> Parser a
-- gmlValue p = symbol "value" *> lexeme p