{-# LANGUAGE CPP #-}

module Language.Dot.Parser
  ( parseDot
#ifdef TEST
  , parseGraph
  , parsePort
  , parseCompass
  , parseAttribute
  , parseId
#endif
  )
  where

import Control.Applicative ((<$>), (<*>), (<*), (*>))
import Control.Monad       (when)
import Data.Char           (digitToInt, toLower)
import Data.List           (foldl')
import Data.Maybe          (fromJust, fromMaybe, isJust)
import Numeric             (readFloat)

import Text.Parsec
import Text.Parsec.Language
import Text.Parsec.String
import Text.Parsec.Token

import Language.Dot.Syntax

-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --

parseDot
  :: String  -- ^ origin of the data, e.g., the name of a file
  -> String  -- ^ DOT source code
  -> Either ParseError Graph
parseDot :: String -> String -> Either ParseError Graph
parseDot String
origin =
    forall s t a.
Stream s Identity t =>
Parsec s () a -> String -> s -> Either ParseError a
parse (Parser ()
whiteSpace' forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ParsecT String () Identity Graph
parseGraph) String
origin forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
preprocess

-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --

preprocess :: String -> String
preprocess :: String -> String
preprocess =
    [String] -> String
unlines forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map String -> String
commentPoundLines forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
lines
  where
    commentPoundLines :: String -> String
commentPoundLines []         = []
    commentPoundLines line :: String
line@(Char
c:String
_) = if Char
c forall a. Eq a => a -> a -> Bool
== Char
'#' then String
"// " forall a. [a] -> [a] -> [a]
++ String
line else String
line

-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --

parseGraph :: Parser Graph
parseGraph :: ParsecT String () Identity Graph
parseGraph =
    ( GraphStrictness
-> GraphDirectedness -> Maybe Id -> [Statement] -> Graph
Graph forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
          Parser GraphStrictness
parseGraphStrictness
      forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser GraphDirectedness
parseGraphDirectedness
      forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m (Maybe a)
optionMaybe Parser Id
parseId
      forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser [Statement]
parseStatementList
    )
    forall s u (m :: * -> *) a.
ParsecT s u m a -> String -> ParsecT s u m a
<?> String
"graph"

parseGraphStrictness :: Parser GraphStrictness
parseGraphStrictness :: Parser GraphStrictness
parseGraphStrictness =
    ((String -> Parser ()
reserved' String
"strict" forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return GraphStrictness
StrictGraph) forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> forall (m :: * -> *) a. Monad m => a -> m a
return GraphStrictness
UnstrictGraph)
    forall s u (m :: * -> *) a.
ParsecT s u m a -> String -> ParsecT s u m a
<?> String
"graph strictness"

parseGraphDirectedness :: Parser GraphDirectedness
parseGraphDirectedness :: Parser GraphDirectedness
parseGraphDirectedness =
    (   (String -> Parser ()
reserved' String
"graph"   forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return GraphDirectedness
UndirectedGraph)
    forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> (String -> Parser ()
reserved' String
"digraph" forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return GraphDirectedness
DirectedGraph)
    )
    forall s u (m :: * -> *) a.
ParsecT s u m a -> String -> ParsecT s u m a
<?> String
"graph directedness"

-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --

parseStatementList :: Parser [Statement]
parseStatementList :: Parser [Statement]
parseStatementList =
    forall a. Parser a -> Parser a
braces' (Parser Statement
parseStatement forall s (m :: * -> *) t u a sep.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m sep -> ParsecT s u m [a]
`endBy` forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m ()
optional Parser String
semi')
    forall s u (m :: * -> *) a.
ParsecT s u m a -> String -> ParsecT s u m a
<?> String
"statement list"

parseStatement :: Parser Statement
parseStatement :: Parser Statement
parseStatement =
    (   forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try Parser Statement
parseEdgeStatement
    forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try Parser Statement
parseAttributeStatement
    forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try Parser Statement
parseAssignmentStatement
    forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try Parser Statement
parseSubgraphStatement
    forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|>     Parser Statement
parseNodeStatement
    )
    forall s u (m :: * -> *) a.
ParsecT s u m a -> String -> ParsecT s u m a
<?> String
"statement"

-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --

parseNodeStatement :: Parser Statement
parseNodeStatement :: Parser Statement
parseNodeStatement =
    ( NodeId -> [Attribute] -> Statement
NodeStatement forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
      Parser NodeId
parseNodeId forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser [Attribute]
parseAttributeList
    )
    forall s u (m :: * -> *) a.
ParsecT s u m a -> String -> ParsecT s u m a
<?> String
"node statement"

-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --

parseEdgeStatement :: Parser Statement
parseEdgeStatement :: Parser Statement
parseEdgeStatement =
    ( [Entity] -> [Attribute] -> Statement
EdgeStatement forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
      Parser [Entity]
parseEntityList forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser [Attribute]
parseAttributeList
    )
    forall s u (m :: * -> *) a.
ParsecT s u m a -> String -> ParsecT s u m a
<?> String
"edge statement"

-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --

parseAttributeStatement :: Parser Statement
parseAttributeStatement :: Parser Statement
parseAttributeStatement =
    ( AttributeStatementType -> [Attribute] -> Statement
AttributeStatement forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
      Parser AttributeStatementType
parseAttributeStatementType forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser [Attribute]
parseAttributeList
    )
    forall s u (m :: * -> *) a.
ParsecT s u m a -> String -> ParsecT s u m a
<?> String
"attribute statement"

parseAttributeStatementType :: Parser AttributeStatementType
parseAttributeStatementType :: Parser AttributeStatementType
parseAttributeStatementType =
    (   (String -> Parser ()
reserved' String
"graph" forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return AttributeStatementType
GraphAttributeStatement)
    forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> (String -> Parser ()
reserved' String
"node"  forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return AttributeStatementType
NodeAttributeStatement)
    forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> (String -> Parser ()
reserved' String
"edge"  forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return AttributeStatementType
EdgeAttributeStatement)
    )
    forall s u (m :: * -> *) a.
ParsecT s u m a -> String -> ParsecT s u m a
<?> String
"attribute statement type"

-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --

parseAssignmentStatement :: Parser Statement
parseAssignmentStatement :: Parser Statement
parseAssignmentStatement =
    ( Id -> Id -> Statement
AssignmentStatement forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
      Parser Id
parseId forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (String -> Parser ()
reservedOp' String
"=" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Id
parseId)
    )
    forall s u (m :: * -> *) a.
ParsecT s u m a -> String -> ParsecT s u m a
<?> String
"assignment statement"

-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --

parseSubgraphStatement :: Parser Statement
parseSubgraphStatement :: Parser Statement
parseSubgraphStatement =
    ( Subgraph -> Statement
SubgraphStatement forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
       Parser Subgraph
parseSubgraph
    )
    forall s u (m :: * -> *) a.
ParsecT s u m a -> String -> ParsecT s u m a
<?> String
"subgraph statement"

parseSubgraph :: Parser Subgraph
parseSubgraph :: Parser Subgraph
parseSubgraph =
    (   forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try Parser Subgraph
parseNewSubgraph
    forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|>     Parser Subgraph
parseSubgraphRef
    )
    forall s u (m :: * -> *) a.
ParsecT s u m a -> String -> ParsecT s u m a
<?> String
"subgraph"

parseNewSubgraph :: Parser Subgraph
parseNewSubgraph :: Parser Subgraph
parseNewSubgraph =
    ( Maybe Id -> [Statement] -> Subgraph
NewSubgraph forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
      (forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m ()
optional (String -> Parser ()
reserved' String
"subgraph") forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m (Maybe a)
optionMaybe Parser Id
parseId) forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser [Statement]
parseStatementList
    )
    forall s u (m :: * -> *) a.
ParsecT s u m a -> String -> ParsecT s u m a
<?> String
"new subgraph"

parseSubgraphRef :: Parser Subgraph
parseSubgraphRef :: Parser Subgraph
parseSubgraphRef =
    ( Id -> Subgraph
SubgraphRef forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
      (String -> Parser ()
reserved' String
"subgraph" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Id
parseId)
    )
    forall s u (m :: * -> *) a.
ParsecT s u m a -> String -> ParsecT s u m a
<?> String
"subgraph ref"

-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --

parseEntityList :: Parser [Entity]
parseEntityList :: Parser [Entity]
parseEntityList =
    ( (:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
      Bool -> Parser Entity
parseEntity Bool
True forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 (Bool -> Parser Entity
parseEntity Bool
False)
    )
    forall s u (m :: * -> *) a.
ParsecT s u m a -> String -> ParsecT s u m a
<?> String
"entity list"

parseEntity :: Bool -> Parser Entity
parseEntity :: Bool -> Parser Entity
parseEntity Bool
first =
    (   forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try (Bool -> Parser Entity
parseENodeId Bool
first)
    forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|>     Bool -> Parser Entity
parseESubgraph Bool
first
    )
    forall s u (m :: * -> *) a.
ParsecT s u m a -> String -> ParsecT s u m a
<?> String
"entity"

parseENodeId :: Bool -> Parser Entity
parseENodeId :: Bool -> Parser Entity
parseENodeId Bool
first =
    ( EdgeType -> NodeId -> Entity
ENodeId forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
      (if Bool
first then forall (m :: * -> *) a. Monad m => a -> m a
return EdgeType
NoEdge else Parser EdgeType
parseEdgeType) forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser NodeId
parseNodeId
    )
    forall s u (m :: * -> *) a.
ParsecT s u m a -> String -> ParsecT s u m a
<?> String
"entity node id"

parseESubgraph :: Bool -> Parser Entity
parseESubgraph :: Bool -> Parser Entity
parseESubgraph Bool
first =
    ( EdgeType -> Subgraph -> Entity
ESubgraph forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
      (if Bool
first then forall (m :: * -> *) a. Monad m => a -> m a
return EdgeType
NoEdge else Parser EdgeType
parseEdgeType) forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Subgraph
parseSubgraph
    )
    forall s u (m :: * -> *) a.
ParsecT s u m a -> String -> ParsecT s u m a
<?> String
"entity subgraph"

parseEdgeType :: Parser EdgeType
parseEdgeType :: Parser EdgeType
parseEdgeType =
    (   forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try (String -> Parser ()
reservedOp' String
"->" forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return EdgeType
DirectedEdge)
    forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|>     (String -> Parser ()
reservedOp' String
"--" forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return EdgeType
UndirectedEdge)
    )
    forall s u (m :: * -> *) a.
ParsecT s u m a -> String -> ParsecT s u m a
<?> String
"edge operator"

-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --

parseNodeId :: Parser NodeId
parseNodeId :: Parser NodeId
parseNodeId =
    ( Id -> Maybe Port -> NodeId
NodeId forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
      Parser Id
parseId forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m (Maybe a)
optionMaybe Parser Port
parsePort
    )
    forall s u (m :: * -> *) a.
ParsecT s u m a -> String -> ParsecT s u m a
<?> String
"node id"

-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --

parsePort :: Parser Port
parsePort :: Parser Port
parsePort =
    (   forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try Parser Port
parsePortC
    forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|>     Parser Port
parsePortI
    )
    forall s u (m :: * -> *) a.
ParsecT s u m a -> String -> ParsecT s u m a
<?> String
"port"

parsePortC :: Parser Port
parsePortC :: Parser Port
parsePortC =
    ( Compass -> Port
PortC forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
      (Parser String
colon' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT String () Identity Compass
parseCompass)
    )
    forall s u (m :: * -> *) a.
ParsecT s u m a -> String -> ParsecT s u m a
<?> String
"port (compass variant)"

parsePortI :: Parser Port
parsePortI :: Parser Port
parsePortI =
    ( Id -> Maybe Compass -> Port
PortI forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
      (Parser String
colon' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Id
parseId) forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m (Maybe a)
optionMaybe (Parser String
colon' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT String () Identity Compass
parseCompass)
    )
    forall s u (m :: * -> *) a.
ParsecT s u m a -> String -> ParsecT s u m a
<?> String
"port (id variant)"

-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --

parseCompass :: Parser Compass
parseCompass :: ParsecT String () Identity Compass
parseCompass =
    (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> Maybe Compass
convert Parser String
identifier' forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall {s} {u} {m :: * -> *} {a}. ParsecT s u m a
err forall (m :: * -> *) a. Monad m => a -> m a
return)
    forall s u (m :: * -> *) a.
ParsecT s u m a -> String -> ParsecT s u m a
<?> String
"compass"
  where
    err :: ParsecT s u m a
err = forall s u (m :: * -> *) a. String -> ParsecT s u m a
parserFail String
"invalid compass value"
    convert :: String -> Maybe Compass
convert =
        forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup [(String, Compass)]
table forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
stringToLower
      where
        table :: [(String, Compass)]
table =
          [ (String
"n",  Compass
CompassN),  (String
"e",  Compass
CompassE),  (String
"s",  Compass
CompassS),  (String
"w",  Compass
CompassW)
          , (String
"ne", Compass
CompassNE), (String
"nw", Compass
CompassNW), (String
"se", Compass
CompassSE), (String
"sw", Compass
CompassSW)
          ]

-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --

parseAttributeList :: Parser [Attribute]
parseAttributeList :: Parser [Attribute]
parseAttributeList =
    (forall a. Parser a -> Parser a
brackets' (Parser Attribute
parseAttribute forall s (m :: * -> *) t u a sep.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m sep -> ParsecT s u m [a]
`sepBy` forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m ()
optional Parser String
comma') forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> forall (m :: * -> *) a. Monad m => a -> m a
return [])
    forall s u (m :: * -> *) a.
ParsecT s u m a -> String -> ParsecT s u m a
<?> String
"attribute list"

parseAttribute :: Parser Attribute
parseAttribute :: Parser Attribute
parseAttribute =
    ( do
      Id
id0 <- Parser Id
parseId
      Maybe Id
id1 <- forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m (Maybe a)
optionMaybe (String -> Parser ()
reservedOp' String
"=" forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parser Id
parseId)
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Id -> Attribute
AttributeSetTrue Id
id0) (Id -> Id -> Attribute
AttributeSetValue Id
id0) Maybe Id
id1
    )
    forall s u (m :: * -> *) a.
ParsecT s u m a -> String -> ParsecT s u m a
<?> String
"attribute"

-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --

parseId :: Parser Id
parseId :: Parser Id
parseId =
    (   forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try Parser Id
parseNameId
    forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try Parser Id
parseStringId
    forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try Parser Id
parseFloatId
    forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try Parser Id
parseIntegerId
    forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|>     Parser Id
parseXmlId
    )
    forall s u (m :: * -> *) a.
ParsecT s u m a -> String -> ParsecT s u m a
<?> String
"id"

parseNameId :: Parser Id
parseNameId :: Parser Id
parseNameId =
    ( String -> Id
NameId forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
      Parser String
identifier'
    )
    forall s u (m :: * -> *) a.
ParsecT s u m a -> String -> ParsecT s u m a
<?> String
"name"

parseStringId :: Parser Id
parseStringId :: Parser Id
parseStringId =
    ( String -> Id
StringId forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
      forall a. Parser a -> Parser a
lexeme' (forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'"' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall s (m :: * -> *) t u a sep.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m sep -> ParsecT s u m [a]
manyTill forall {u}. ParsecT String u Identity Char
stringChar (forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'"'))
    )
    forall s u (m :: * -> *) a.
ParsecT s u m a -> String -> ParsecT s u m a
<?> String
"string literal"
  where
    stringChar :: ParsecT String u Identity Char
stringChar =
        (forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try (forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
string String
"\\\"" forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return Char
'"') forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m Char
noneOf String
"\"")
        forall s u (m :: * -> *) a.
ParsecT s u m a -> String -> ParsecT s u m a
<?> String
"string character"

-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --

-- | DOT allows floating point numbers having no whole part like @.123@, but
--   Parsec 'float' does not accept them.
parseFloatId :: Parser Id
parseFloatId :: Parser Id
parseFloatId =
    forall a. Parser a -> Parser a
lexeme'
      ( do Float -> Float
s <- forall a. Num a => Parser (a -> a)
parseSign
           Integer
l <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. a -> Maybe a -> a
fromMaybe Integer
0) (forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m (Maybe a)
optionMaybe Parser Integer
parseNatural)
           Char
_ <- forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'.'
           String
r <- forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
digit
           forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall {s} {u} {m :: * -> *} {a}. ParsecT s u m a
err forall (m :: * -> *) a. Monad m => a -> m a
return (forall {a}. RealFrac a => (a -> Float) -> String -> Maybe Id
make Float -> Float
s (forall a. Show a => a -> String
show Integer
l forall a. [a] -> [a] -> [a]
++ String
"." forall a. [a] -> [a] -> [a]
++ String
r))
      )
    forall s u (m :: * -> *) a.
ParsecT s u m a -> String -> ParsecT s u m a
<?> String
"float"
  where
    err :: ParsecT s u m a
err = forall s u (m :: * -> *) a. String -> ParsecT s u m a
parserFail String
"invalid float value"
    make :: (a -> Float) -> String -> Maybe Id
make a -> Float
s String
f =
        case forall a. RealFrac a => ReadS a
readFloat String
f of
          [(a
v,String
"")] -> (forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. Float -> Id
FloatId forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Float
s) a
v
          [(a, String)]
_        -> forall a. Maybe a
Nothing

parseSign :: (Num a) => Parser (a -> a)
parseSign :: forall a. Num a => Parser (a -> a)
parseSign =
    (   (forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'-' forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Num a => a -> a
negate)
    forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> (forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'+' forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. a -> a
id)
    forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. a -> a
id
    )
    forall s u (m :: * -> *) a.
ParsecT s u m a -> String -> ParsecT s u m a
<?> String
"sign"

-- | Non-'lexeme' variant of 'natural' for parsing the natural part of a float.
parseNatural :: Parser Integer
parseNatural :: Parser Integer
parseNatural =
    (   (forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'0' forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return Integer
0)
    forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> (String -> Integer
convert forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
digit)
    )
    forall s u (m :: * -> *) a.
ParsecT s u m a -> String -> ParsecT s u m a
<?> String
"natural"
  where
    convert :: String -> Integer
convert = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\Integer
acc Char
d -> Integer
10 forall a. Num a => a -> a -> a
* Integer
acc forall a. Num a => a -> a -> a
+ forall a b. (Integral a, Num b) => a -> b
fromIntegral (Char -> Int
digitToInt Char
d)) Integer
0

-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --

parseIntegerId :: Parser Id
parseIntegerId :: Parser Id
parseIntegerId =
    ( Integer -> Id
IntegerId forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
      Parser Integer
integer'
    )
    forall s u (m :: * -> *) a.
ParsecT s u m a -> String -> ParsecT s u m a
<?> String
"integer"

-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --

parseXmlId :: Parser Id
parseXmlId :: Parser Id
parseXmlId =
    ( Xml -> Id
XmlId forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
      forall a. Parser a -> Parser a
angles' Parser Xml
parseXml
    )
    forall s u (m :: * -> *) a.
ParsecT s u m a -> String -> ParsecT s u m a
<?> String
"XML id"

parseXml :: Parser Xml
parseXml :: Parser Xml
parseXml =
    (   forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try Parser Xml
parseXmlEmptyTag
    forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try Parser Xml
parseXmlTag
    forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|>     Parser Xml
parseXmlText
    )
    forall s u (m :: * -> *) a.
ParsecT s u m a -> String -> ParsecT s u m a
<?> String
"XML"

parseXmlEmptyTag :: Parser Xml
parseXmlEmptyTag :: Parser Xml
parseXmlEmptyTag =
    ( XmlName -> [XmlAttribute] -> Xml
XmlEmptyTag forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
      (forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'<' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT String () Identity XmlName
parseXmlName) forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (ParsecT String () Identity [XmlAttribute]
parseXmlAttributes forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* (forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'/' forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'>'))
    )
    forall s u (m :: * -> *) a.
ParsecT s u m a -> String -> ParsecT s u m a
<?> String
"XML empty tag"

parseXmlTag :: Parser Xml
parseXmlTag :: Parser Xml
parseXmlTag =
    ( do (XmlName
name, [XmlAttribute]
attributes) <- Parser (XmlName, [XmlAttribute])
parseXmlTagOpen
         [Xml]
elements           <- forall s (m :: * -> *) t u a sep.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m sep -> ParsecT s u m [a]
manyTill Parser Xml
parseXml (forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m a
lookAhead (forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try (Maybe XmlName -> Parser ()
parseXmlTagClose (forall a. a -> Maybe a
Just XmlName
name))))
         Maybe XmlName -> Parser ()
parseXmlTagClose (forall a. a -> Maybe a
Just XmlName
name)
         forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ XmlName -> [XmlAttribute] -> [Xml] -> Xml
XmlTag XmlName
name [XmlAttribute]
attributes [Xml]
elements
    )
    forall s u (m :: * -> *) a.
ParsecT s u m a -> String -> ParsecT s u m a
<?> String
"XML tag"

parseXmlTagOpen :: Parser (XmlName, [XmlAttribute])
parseXmlTagOpen :: Parser (XmlName, [XmlAttribute])
parseXmlTagOpen =
    ( (,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
      (forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'<' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT String () Identity XmlName
parseXmlName) forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (ParsecT String () Identity [XmlAttribute]
parseXmlAttributes forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'>')
    )
    forall s u (m :: * -> *) a.
ParsecT s u m a -> String -> ParsecT s u m a
<?> String
"XML opening tag"

parseXmlTagClose :: Maybe XmlName -> Parser ()
parseXmlTagClose :: Maybe XmlName -> Parser ()
parseXmlTagClose Maybe XmlName
mn0 =
    ( do Char
_  <- forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'<'
         Char
_  <- forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'/'
         XmlName
n1 <- ParsecT String () Identity XmlName
parseXmlName
         Char
_  <- forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'>'
         forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a. Maybe a -> Bool
isJust Maybe XmlName
mn0 Bool -> Bool -> Bool
&& forall a. HasCallStack => Maybe a -> a
fromJust Maybe XmlName
mn0 forall a. Eq a => a -> a -> Bool
/= XmlName
n1) forall {s} {u} {m :: * -> *} {a}. ParsecT s u m a
parserZero
    )
    forall s u (m :: * -> *) a.
ParsecT s u m a -> String -> ParsecT s u m a
<?> String
"XML closing tag " forall a. [a] -> [a] -> [a]
++ String
"(" forall a. [a] -> [a] -> [a]
++ String
which forall a. [a] -> [a] -> [a]
++ String
")"
  where
    which :: String
which =
        case Maybe XmlName
mn0 of
          Just (XmlName String
n) -> String
"for " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show String
n
          Maybe XmlName
Nothing          -> String
"any"

parseXmlText :: Parser Xml
parseXmlText :: Parser Xml
parseXmlText =
    ( String -> Xml
XmlText forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
      forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
anyChar forall s (m :: * -> *) t u a sep.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m sep -> ParsecT s u m [a]
`manyTill` forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m a
lookAhead (   forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try (Parser Xml
parseXmlEmptyTag forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return ())
                                   forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try (Parser Xml
parseXmlTag      forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return ())
                                   forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|>      Maybe XmlName -> Parser ()
parseXmlTagClose forall a. Maybe a
Nothing
                                   )
    )
    forall s u (m :: * -> *) a.
ParsecT s u m a -> String -> ParsecT s u m a
<?> String
"XML text"

parseXmlAttributes :: Parser [XmlAttribute]
parseXmlAttributes :: ParsecT String () Identity [XmlAttribute]
parseXmlAttributes =
    forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many Parser XmlAttribute
parseXmlAttribute
    forall s u (m :: * -> *) a.
ParsecT s u m a -> String -> ParsecT s u m a
<?> String
"XML attribute list"

parseXmlAttribute :: Parser XmlAttribute
parseXmlAttribute :: Parser XmlAttribute
parseXmlAttribute =
    ( XmlName -> XmlAttributeValue -> XmlAttribute
XmlAttribute forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
      (ParsecT String () Identity XmlName
parseXmlName forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* String -> Parser ()
reservedOp' String
"=") forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser XmlAttributeValue
parseXmlAttributeValue
    )
    forall s u (m :: * -> *) a.
ParsecT s u m a -> String -> ParsecT s u m a
<?> String
"XML attribute"

parseXmlAttributeValue :: Parser XmlAttributeValue
parseXmlAttributeValue :: Parser XmlAttributeValue
parseXmlAttributeValue =
    ( String -> XmlAttributeValue
XmlAttributeValue forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
      Parser String
stringLiteral'
    )
    forall s u (m :: * -> *) a.
ParsecT s u m a -> String -> ParsecT s u m a
<?> String
"XML attribute value"

parseXmlName :: Parser XmlName
parseXmlName :: ParsecT String () Identity XmlName
parseXmlName =
    ( String -> XmlName
XmlName forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
      ((:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall {u}. ParsecT String u Identity Char
c0 forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many forall {u}. ParsecT String u Identity Char
c1 forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
whiteSpace'))
    )
    forall s u (m :: * -> *) a.
ParsecT s u m a -> String -> ParsecT s u m a
<?> String
"XML name"
  where
    c0 :: ParsecT String u Identity Char
c0 = forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
letter   forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> forall {u}. ParsecT String u Identity Char
cs
    c1 :: ParsecT String u Identity Char
c1 = forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
alphaNum forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> forall {u}. ParsecT String u Identity Char
cs
    cs :: ParsecT String u Identity Char
cs = forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m Char
oneOf String
"-.:_"

-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --

angles'        :: Parser a -> Parser a
braces'        :: Parser a -> Parser a
brackets'      :: Parser a -> Parser a
colon'         :: Parser String
comma'         :: Parser String
identifier'    :: Parser String
integer'       :: Parser Integer
lexeme'        :: Parser a -> Parser a
reserved'      :: String -> Parser ()
reservedOp'    :: String -> Parser ()
semi'          :: Parser String
stringLiteral' :: Parser String
whiteSpace'    :: Parser ()

angles' :: forall a. Parser a -> Parser a
angles'        = forall s u (m :: * -> *).
GenTokenParser s u m
-> forall a. ParsecT s u m a -> ParsecT s u m a
angles        TokenParser ()
lexer
braces' :: forall a. Parser a -> Parser a
braces'        = forall s u (m :: * -> *).
GenTokenParser s u m
-> forall a. ParsecT s u m a -> ParsecT s u m a
braces        TokenParser ()
lexer
brackets' :: forall a. Parser a -> Parser a
brackets'      = forall s u (m :: * -> *).
GenTokenParser s u m
-> forall a. ParsecT s u m a -> ParsecT s u m a
brackets      TokenParser ()
lexer
colon' :: Parser String
colon'         = forall s u (m :: * -> *).
GenTokenParser s u m -> ParsecT s u m String
colon         TokenParser ()
lexer
comma' :: Parser String
comma'         = forall s u (m :: * -> *).
GenTokenParser s u m -> ParsecT s u m String
comma         TokenParser ()
lexer
identifier' :: Parser String
identifier'    = forall s u (m :: * -> *).
GenTokenParser s u m -> ParsecT s u m String
identifier    TokenParser ()
lexer
integer' :: Parser Integer
integer'       = forall s u (m :: * -> *).
GenTokenParser s u m -> ParsecT s u m Integer
integer       TokenParser ()
lexer
lexeme' :: forall a. Parser a -> Parser a
lexeme'        = forall s u (m :: * -> *).
GenTokenParser s u m
-> forall a. ParsecT s u m a -> ParsecT s u m a
lexeme        TokenParser ()
lexer
reserved' :: String -> Parser ()
reserved'      = forall s u (m :: * -> *).
GenTokenParser s u m -> String -> ParsecT s u m ()
reserved      TokenParser ()
lexer
reservedOp' :: String -> Parser ()
reservedOp'    = forall s u (m :: * -> *).
GenTokenParser s u m -> String -> ParsecT s u m ()
reservedOp    TokenParser ()
lexer
semi' :: Parser String
semi'          = forall s u (m :: * -> *).
GenTokenParser s u m -> ParsecT s u m String
semi          TokenParser ()
lexer
stringLiteral' :: Parser String
stringLiteral' = forall s u (m :: * -> *).
GenTokenParser s u m -> ParsecT s u m String
stringLiteral TokenParser ()
lexer
whiteSpace' :: Parser ()
whiteSpace'    = forall s u (m :: * -> *). GenTokenParser s u m -> ParsecT s u m ()
whiteSpace    TokenParser ()
lexer

lexer :: TokenParser ()
lexer :: TokenParser ()
lexer =
    forall s (m :: * -> *) u.
Stream s m Char =>
GenLanguageDef s u m -> GenTokenParser s u m
makeTokenParser forall {u}. GenLanguageDef String u Identity
dotDef
  where
    dotDef :: GenLanguageDef String u Identity
dotDef = forall {u}. GenLanguageDef String u Identity
emptyDef
      { commentStart :: String
commentStart    = String
"/*"
      , commentEnd :: String
commentEnd      = String
"*/"
      , commentLine :: String
commentLine     = String
"//"
      , nestedComments :: Bool
nestedComments  = Bool
True
      , identStart :: ParsecT String u Identity Char
identStart      = forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
letter   forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'_'
      , identLetter :: ParsecT String u Identity Char
identLetter     = forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
alphaNum forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'_'
      , opStart :: ParsecT String u Identity Char
opStart         = forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m Char
oneOf String
"-="
      , opLetter :: ParsecT String u Identity Char
opLetter        = forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m Char
oneOf String
""
      , reservedOpNames :: [String]
reservedOpNames = [String
"->", String
"--", String
"="]
      , reservedNames :: [String]
reservedNames   = [String
"digraph", String
"edge", String
"graph", String
"node", String
"strict", String
"subgraph"]
      , caseSensitive :: Bool
caseSensitive   = Bool
False
      }

-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --

stringToLower :: String -> String
stringToLower :: String -> String
stringToLower = forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower