{-# 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 :: forall a b. GMLGraph a b -> Graph a
gmlGraph (GMLGraph Maybe String
_ [GMLNode a]
_ [GMLEdge a b]
es) =
  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
_) -> forall a. a -> a -> Graph a
G.edge a
a a
b forall a. Graph a -> Graph a -> Graph a
`G.overlay` Graph a
gr) forall a. Graph a
G.empty [GMLEdge a b]
es

-- | Graph entities of the GML graph format
data GMLGraph a b = GMLGraph {
  forall a b. GMLGraph a b -> Maybe String
gmlHeader :: Maybe String
  , forall a b. GMLGraph a b -> [GMLNode a]
gmlNodes :: [GMLNode a]
  , forall a b. GMLGraph a b -> [GMLEdge a b]
gmlEdges :: [GMLEdge a b]
  } deriving (Int -> GMLGraph a b -> ShowS
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 :: forall a b. Parser a -> Parser b -> Parser (GMLGraph a b)
gmlGraphP Parser a
p Parser b
p2 = do
  Maybe String
header <- forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional Parser String
creator -- header
  forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ Text -> Parser Text
symbol Text
"graph"
  forall a. Parser a -> Parser a
sqBkts forall a b. (a -> b) -> a -> b
$ do
    [GMLNode a]
ns <- forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many forall a b. (a -> b) -> a -> b
$ forall a. Parser a -> Parser (GMLNode a)
gmlNode Parser a
p
    [GMLEdge a b]
es <- forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many forall a b. (a -> b) -> a -> b
$ forall a b. Parser a -> Parser b -> Parser (GMLEdge a b)
gmlEdge Parser a
p Parser b
p2
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> 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 :: Parser String
creator = do
  forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ Text -> Parser Text
symbol Text
"Creator"
  forall a. Parser a -> Parser a
quoted forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many forall a b. (a -> b) -> a -> b
$ forall e s (m :: * -> *).
MonadParsec e s m =>
(Token s -> Bool) -> m (Token s)
satisfy (forall a. Eq a => a -> a -> Bool
/= Char
'\"')

-- | GML nodes
data GMLNode a = GMLNode a (Maybe String) deriving (Int -> GMLNode a -> ShowS
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 :: forall a. Parser a -> Parser (GMLNode a)
gmlNode Parser a
p = do
  forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ Text -> Parser Text
symbol Text
"node"
  forall a. Parser a -> Parser a
sqBkts forall a b. (a -> b) -> a -> b
$ do
    a
n <- Text -> Parser Text
symbol Text
"id" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall a. Parser a -> Parser a
lexeme Parser a
p
    Maybe String
l <- forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional Parser String
gmlLabel
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe String -> GMLNode a
GMLNode a
n Maybe String
l

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

-- | GML edges
data GMLEdge a b = GMLEdge a a (Maybe b) (Maybe String) deriving (Int -> GMLEdge a b -> ShowS
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 :: forall a b. Parser a -> Parser b -> Parser (GMLEdge a b)
gmlEdge Parser a
pa Parser b
pb = do
  forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ Text -> Parser Text
symbol Text
"edge"
  forall a. Parser a -> Parser a
sqBkts forall a b. (a -> b) -> a -> b
$ do
    a
a <- forall a. Parser a -> Parser a
source Parser a
pa
    a
b <- forall a. Parser a -> Parser a
target Parser a
pa
    Maybe b
v <- forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (forall a. Parser a -> Parser a
value Parser b
pb)
    Maybe String
l <- forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional Parser String
gmlLabel
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> 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 :: forall a. Parser a -> Parser a
source = forall a. Text -> Parser a -> Parser a
attr Text
"source"
target :: forall a. Parser a -> Parser a
target = forall a. Text -> Parser a -> Parser a
attr Text
"target"
value :: forall a. Parser a -> Parser a
value = forall a. Text -> Parser a -> Parser a
attr Text
"value"

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

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


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