{-# LANGUAGE FlexibleInstances, OverloadedStrings #-}

{- |
   Module      : Data.GraphViz.Parsing
   Description : Helper functions for Parsing.
   Copyright   : (c) Matthew Sackman, Ivan Lazar Miljenovic
   License     : 3-Clause BSD-style
   Maintainer  : Ivan.Miljenovic@gmail.com

   This module defines simple helper functions for use with
   "Text.ParserCombinators.Poly.Lazy".

   Note that the 'ParseDot' instances for 'Bool', etc. match those
   specified for use with Graphviz (e.g. non-zero integers are
   equivalent to 'True').

   You should not be using this module; rather, it is here for
   informative/documentative reasons.  If you want to parse a
   @'Data.GraphViz.Types.DotRepr'@, you should use
   @'Data.GraphViz.Types.parseDotGraph'@ rather than its 'ParseDot'
   instance.
-}
module Data.GraphViz.Parsing
    ( -- * Re-exporting pertinent parts of Polyparse.
      module Text.ParserCombinators.Poly.StateText
      -- * The ParseDot class.
    , Parse
    , ParseDot(..)
    , parseIt
    , parseIt'
    , runParser
    , runParser'
    , runParserWith
    , parseLiberally
    , checkValidParse
    , checkValidParseWithRest
      -- * Convenience parsing combinators.
    , ignoreSep
    , onlyBool
    , quotelessString
    , stringBlock
    , numString
    , isNumString
    , isIntString
    , quotedString
    , parseEscaped
    , parseAndSpace
    , string
    , strings
    , character
    , parseStrictFloat
    , parseSignedFloat
    , noneOf
    , whitespace1
    , whitespace
    , wrapWhitespace
    , optionalQuotedString
    , optionalQuoted
    , quotedParse
    , orQuote
    , quoteChar
    , newline
    , newline'
    , parseComma
    , parseEq
    , tryParseList
    , tryParseList'
    , consumeLine
    , commaSep
    , commaSepUnqt
    , commaSep'
    , stringRep
    , stringReps
    , stringParse
    , stringValue
    , parseAngled
    , parseBraced
    , parseColorScheme
    ) where

import Data.GraphViz.Exception      (GraphvizException(NotDotCode), throw)
import Data.GraphViz.Internal.State
import Data.GraphViz.Internal.Util

-- To avoid orphan instances and cyclic imports
import Data.GraphViz.Attributes.ColorScheme

import           Text.ParserCombinators.Poly.StateText hiding (empty, indent,
                                                        runParser)
import qualified Text.ParserCombinators.Poly.StateText as P

import           Control.Arrow       (first, second)
import           Control.Monad       (when)
import           Data.Char           (isDigit, isLower, isSpace, toLower,
                                      toUpper)
import           Data.Function       (on)
import           Data.List           (groupBy, sortBy)
import           Data.Maybe          (fromMaybe, isJust, isNothing, listToMaybe,
                                      maybeToList)
import           Data.Ratio          ((%))
import qualified Data.Set            as Set
import qualified Data.Text           as ST
import           Data.Text.Lazy      (Text)
import qualified Data.Text.Lazy      as T
import qualified Data.Text.Lazy.Read as T
import           Data.Version        (Version(..))
import           Data.Word           (Word16, Word8)

-- -----------------------------------------------------------------------------
-- Based off code from Text.Parse in the polyparse library

-- | A @ReadS@-like type alias.
type Parse a = Parser GraphvizState a

runParser :: Parse a -> Text -> (Either String a, Text)
runParser :: forall a. Parse a -> Text -> (Either [Char] a, Text)
runParser = forall a.
(GraphvizState -> GraphvizState)
-> Parse a -> Text -> (Either [Char] a, Text)
runParserWith forall a. a -> a
id

parseLiberally    :: GraphvizState -> GraphvizState
parseLiberally :: GraphvizState -> GraphvizState
parseLiberally GraphvizState
gs = GraphvizState
gs { parseStrictly :: Bool
parseStrictly = Bool
False }

runParserWith     :: (GraphvizState -> GraphvizState) -> Parse a -> Text
                     -> (Either String a, Text)
runParserWith :: forall a.
(GraphvizState -> GraphvizState)
-> Parse a -> Text -> (Either [Char] a, Text)
runParserWith GraphvizState -> GraphvizState
f Parse a
p Text
t = let (Either [Char] a
r,GraphvizState
_,Text
t') = forall s a. Parser s a -> s -> Text -> (Either [Char] a, s, Text)
P.runParser Parse a
p (GraphvizState -> GraphvizState
f GraphvizState
initialState) Text
t
                      in (Either [Char] a
r,Text
t')

-- | A variant of 'runParser' where it is assumed that the provided
--   parsing function consumes all of the 'Text' input (with the
--   exception of whitespace at the end).
runParser'   :: Parse a -> Text -> a
runParser' :: forall a. Parse a -> Text -> a
runParser' Parse a
p = forall a. (Either [Char] a, Text) -> a
checkValidParseWithRest forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Parse a -> Text -> (Either [Char] a, Text)
runParser Parse a
p'
  where
    p' :: Parse a
p' = Parse a
p forall (p :: * -> *) a b. PolyParse p => p a -> p b -> p a
`discard` (Parser GraphvizState ()
whitespace forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall s. Parser s ()
eof)

class ParseDot a where
  parseUnqt :: Parse a

  parse :: Parse a
  parse = forall a. Parse a -> Parse a
optionalQuoted forall a. ParseDot a => Parse a
parseUnqt

  parseUnqtList :: Parse [a]
  parseUnqtList = forall (p :: * -> *) bra sep ket a.
PolyParse p =>
p bra -> p sep -> p ket -> p a -> p [a]
bracketSep (forall a. Parse a -> Parse a
parseAndSpace forall a b. (a -> b) -> a -> b
$ Char -> Parse Char
character Char
'[')
                             ( forall a. Parse a -> Parse a
wrapWhitespace Parser GraphvizState ()
parseComma
                               forall s a. Parser s a -> Parser s a -> Parser s a
`onFail`
                               Parser GraphvizState ()
whitespace1
                             )
                             (Parser GraphvizState ()
whitespace forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Char -> Parse Char
character Char
']')
                             forall a. ParseDot a => Parse a
parseUnqt

  parseList :: Parse [a]
  parseList = forall a. Parse a -> Parse a
quotedParse forall a. ParseDot a => Parse [a]
parseUnqtList

-- | Parse the required value, returning also the rest of the input
--   'Text' that hasn't been parsed (for debugging purposes).
parseIt :: (ParseDot a) => Text -> (a, Text)
parseIt :: forall a. ParseDot a => Text -> (a, Text)
parseIt = forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first forall a. Either [Char] a -> a
checkValidParse forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Parse a -> Text -> (Either [Char] a, Text)
runParser forall a. ParseDot a => Parse a
parse

-- | If unable to parse /Dot/ code properly, 'throw' a
--   'GraphvizException'.
checkValidParse :: Either String a -> a
checkValidParse :: forall a. Either [Char] a -> a
checkValidParse (Left [Char]
err) = forall a e. Exception e => e -> a
throw ([Char] -> GraphvizException
NotDotCode [Char]
err)
checkValidParse (Right a
a)  = a
a

-- | If unable to parse /Dot/ code properly, 'throw' a
--   'GraphvizException', with the error containing the remaining
--   unparsed code..
checkValidParseWithRest :: (Either String a, Text) -> a
checkValidParseWithRest :: forall a. (Either [Char] a, Text) -> a
checkValidParseWithRest (Left [Char]
err, Text
rst) = forall a e. Exception e => e -> a
throw ([Char] -> GraphvizException
NotDotCode [Char]
err')
  where
    err' :: [Char]
err' = [Char]
err forall a. [a] -> [a] -> [a]
++ [Char]
"\n\nRemaining input:\n\t" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Text
rst
checkValidParseWithRest (Right a
a,Text
_)     = a
a

-- | Parse the required value with the assumption that it will parse
--   all of the input 'Text'.
parseIt' :: (ParseDot a) => Text -> a
parseIt' :: forall a. ParseDot a => Text -> a
parseIt' = forall a. Parse a -> Text -> a
runParser' forall a. ParseDot a => Parse a
parse

instance ParseDot Int where
  parseUnqt :: Parse Int
parseUnqt = Parse Int
parseSignedInt

instance ParseDot Integer where
  parseUnqt :: Parse Integer
parseUnqt = forall a. Num a => Parse a -> Parse a
parseSigned forall a. Integral a => Parse a
parseInt

instance ParseDot Word8 where
  parseUnqt :: Parse Word8
parseUnqt = forall a. Integral a => Parse a
parseInt

instance ParseDot Word16 where
  parseUnqt :: Parse Word16
parseUnqt = forall a. Integral a => Parse a
parseInt

instance ParseDot Double where
  parseUnqt :: Parse Double
parseUnqt = Bool -> Parse Double
parseSignedFloat Bool
True

  parse :: Parse Double
parse = forall a. Parse a -> Parse a
quotedParse forall a. ParseDot a => Parse a
parseUnqt
          forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Bool -> Parse Double
parseSignedFloat Bool
False

  parseUnqtList :: Parse [Double]
parseUnqtList = forall (p :: * -> *) a sep. PolyParse p => p a -> p sep -> p [a]
sepBy1 forall a. ParseDot a => Parse a
parseUnqt (Char -> Parse Char
character Char
':')

  parseList :: Parse [Double]
parseList = forall a. Parse a -> Parse a
quotedParse forall a. ParseDot a => Parse [a]
parseUnqtList
              forall s a. Parser s a -> Parser s a -> Parser s a
`onFail`
              forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. a -> [a] -> [a]
:[]) forall a. ParseDot a => Parse a
parse

instance ParseDot Bool where
  parseUnqt :: Parse Bool
parseUnqt = Parse Bool
onlyBool
              forall s a. Parser s a -> Parser s a -> Parser s a
`onFail`
              forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int
zero forall a. Eq a => a -> a -> Bool
/=) Parse Int
parseSignedInt
    where
      zero :: Int
      zero :: Int
zero = Int
0

-- | Use this when you do not want numbers to be treated as 'Bool' values.
onlyBool :: Parse Bool
onlyBool :: Parse Bool
onlyBool = forall (p :: * -> *) a. PolyParse p => [p a] -> p a
oneOf [ forall a. a -> [Char] -> Parse a
stringRep Bool
True [Char]
"true"
                 , forall a. a -> [Char] -> Parse a
stringRep Bool
False [Char]
"false"
                 ]

instance ParseDot Char where
  -- Can't be a quote character.
  parseUnqt :: Parse Char
parseUnqt = forall s. (Char -> Bool) -> Parser s Char
satisfy (Char
quoteChar forall a. Eq a => a -> a -> Bool
/=)

  parse :: Parse Char
parse = forall s. (Char -> Bool) -> Parser s Char
satisfy Char -> Bool
restIDString
          forall s a. Parser s a -> Parser s a -> Parser s a
`onFail`
          forall a. Parse a -> Parse a
quotedParse forall a. ParseDot a => Parse a
parseUnqt

  parseUnqtList :: Parse [Char]
parseUnqtList = Text -> [Char]
T.unpack forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. ParseDot a => Parse a
parseUnqt

  parseList :: Parse [Char]
parseList = Text -> [Char]
T.unpack forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. ParseDot a => Parse a
parse

-- | Ignores 'versionTags' and assumes 'not . null . versionBranch'
--   (usually you want 'length . versionBranch == 2') and that all
--   such values are non-negative.
instance ParseDot Version where
  parseUnqt :: Parse Version
parseUnqt = [Int] -> Version
createVersion forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (p :: * -> *) a sep. PolyParse p => p a -> p sep -> p [a]
sepBy1 (forall a. Integral a => Bool -> Parse a
parseIntCheck Bool
False) (Char -> Parse Char
character Char
'.')

  parse :: Parse Version
parse = forall a. Parse a -> Parse a
quotedParse forall a. ParseDot a => Parse a
parseUnqt
          forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
          ([Int] -> Version
createVersion forall b c a. (b -> c) -> (a -> b) -> a -> c
.) forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Maybe a -> [a]
maybeToList) forall b c a. (b -> c) -> (a -> b) -> a -> c
. (:)
             forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall a. Integral a => Bool -> Parse a
parseIntCheck Bool
False) forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (Char -> Parse Char
character Char
'.' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall a. Integral a => Parse a
parseInt)
             -- Leave the last one to check for possible decimals
             -- afterwards as there should be at most two version
             -- numbers here.

instance ParseDot Text where
  -- Too many problems with using this within other parsers where
  -- using numString or stringBlock will cause a parse failure.  As
  -- such, this will successfully parse all un-quoted Texts.
  parseUnqt :: Parse Text
parseUnqt = Parse Text
quotedString

  parse :: Parse Text
parse = Parse Text
quotelessString
          forall s a. Parser s a -> Parser s a -> Parser s a
`onFail`
          -- This will also take care of quoted versions of
          -- above.
          forall a. Parse a -> Parse a
quotedParse Parse Text
quotedString

instance ParseDot ST.Text where
  parseUnqt :: Parse Text
parseUnqt = Text -> Text
T.toStrict forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. ParseDot a => Parse a
parseUnqt

  parse :: Parse Text
parse = Text -> Text
T.toStrict forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. ParseDot a => Parse a
parse

instance (ParseDot a) => ParseDot [a] where
  parseUnqt :: Parse [a]
parseUnqt = forall a. ParseDot a => Parse [a]
parseUnqtList

  parse :: Parse [a]
parse = forall a. ParseDot a => Parse [a]
parseList

-- | Parse a 'Text' that doesn't need to be quoted.
quotelessString :: Parse Text
quotelessString :: Parse Text
quotelessString = Bool -> Parse Text
numString Bool
False forall s a. Parser s a -> Parser s a -> Parser s a
`onFail` Parse Text
stringBlock

numString :: Bool -> Parse Text
numString :: Bool -> Parse Text
numString Bool
q = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. Show a => a -> Text
tShow (Bool -> Parse Double
parseStrictFloat Bool
q)
              forall s a. Parser s a -> Parser s a -> Parser s a
`onFail`
              forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. Show a => a -> Text
tShow Parse Int
parseSignedInt
  where
    tShow :: (Show a) => a -> Text
    tShow :: forall a. Show a => a -> Text
tShow = [Char] -> Text
T.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> [Char]
show

stringBlock :: Parse Text
stringBlock :: Parse Text
stringBlock = forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 Char -> Text -> Text
T.cons (forall s. (Char -> Bool) -> Parser s Char
satisfy Char -> Bool
frstIDString) (forall s. (Char -> Bool) -> Parser s Text
manySatisfy Char -> Bool
restIDString)

-- | Used when quotes are explicitly required;
quotedString :: Parse Text
quotedString :: Parse Text
quotedString = Bool -> [Char] -> [Char] -> Parse Text
parseEscaped Bool
True [] []

parseSigned :: (Num a) => Parse a -> Parse a
parseSigned :: forall a. Num a => Parse a -> Parse a
parseSigned Parse a
p = (Char -> Parse Char
character Char
'-' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. Num a => a -> a
negate Parse a
p)
                forall s a. Parser s a -> Parser s a -> Parser s a
`onFail`
                Parse a
p

parseInt :: (Integral a) => Parse a
parseInt :: forall a. Integral a => Parse a
parseInt = forall a. Integral a => Bool -> Parse a
parseIntCheck Bool
True

-- | Flag indicates whether to check whether the number is actually a
--   floating-point value.
parseIntCheck    :: (Integral a) => Bool -> Parse a
parseIntCheck :: forall a. Integral a => Bool -> Parse a
parseIntCheck Bool
ch = do Text
cs <- forall s. (Char -> Bool) -> Parser s Text
many1Satisfy Char -> Bool
isDigit
                            forall (p :: * -> *) a.
Commitment p =>
p a -> ([Char] -> [Char]) -> p a
`adjustErr` ([Char]
"Expected one or more digits\n\t"forall a. [a] -> [a] -> [a]
++)
                      case forall a. Integral a => Reader a
T.decimal Text
cs of
                        Right (a
n,Text
"")  -> forall a. a -> a -> Bool -> a
bool forall (m :: * -> *) a. Monad m => a -> m a
return forall {b}. b -> Parser GraphvizState b
checkInt Bool
ch a
n
                        -- This case should never actually happen...
                        Right (a
_,Text
txt) -> forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail forall a b. (a -> b) -> a -> b
$ [Char]
"Trailing digits not parsed as Integral: " forall a. [a] -> [a] -> [a]
++ Text -> [Char]
T.unpack Text
txt
                        Left [Char]
err      -> forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail forall a b. (a -> b) -> a -> b
$ [Char]
"Could not read Integral: " forall a. [a] -> [a] -> [a]
++ [Char]
err
  where
    checkInt :: b -> Parser GraphvizState b
checkInt b
n = do Maybe Char
c <- forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional forall a b. (a -> b) -> a -> b
$ forall (p :: * -> *) a. PolyParse p => [p a] -> p a
oneOf [ Char -> Parse Char
character Char
'.', Char -> Parse Char
character Char
'e' ]
                    if forall a. Maybe a -> Bool
isJust Maybe Char
c
                      then forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"This number is actually Floating, not Integral!"
                      else forall (m :: * -> *) a. Monad m => a -> m a
return b
n

parseSignedInt :: Parse Int
parseSignedInt :: Parse Int
parseSignedInt = forall a. Num a => Parse a -> Parse a
parseSigned forall a. Integral a => Parse a
parseInt

-- | Parse a floating point number that actually contains decimals.
--   Bool flag indicates whether values that need to be quoted are
--   parsed.
parseStrictFloat :: Bool -> Parse Double
parseStrictFloat :: Bool -> Parse Double
parseStrictFloat = forall a. Num a => Parse a -> Parse a
parseSigned forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. RealFrac a => Bool -> Parse a
parseFloat

-- | Bool flag indicates whether to allow parsing exponentiated term,
-- as this is only allowed when quoted.
parseFloat :: (RealFrac a) => Bool -> Parse a
parseFloat :: forall a. RealFrac a => Bool -> Parse a
parseFloat Bool
q = do Text
ds   <- forall s. (Char -> Bool) -> Parser s Text
manySatisfy Char -> Bool
isDigit
                  Maybe Text
frac <- forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional forall a b. (a -> b) -> a -> b
$ Char -> Parse Char
character Char
'.' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall s. (Char -> Bool) -> Parser s Text
manySatisfy Char -> Bool
isDigit
                  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Text -> Bool
T.null Text
ds Bool -> Bool -> Bool
&& Maybe Text -> Bool
noDec Maybe Text
frac)
                    (forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"No actual digits in floating point number!")
                  Maybe Int
expn  <- forall a. a -> a -> Bool -> a
bool (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing) (forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional Parse Int
parseExp) Bool
q
                  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a. Maybe a -> Bool
isNothing Maybe Text
frac Bool -> Bool -> Bool
&& forall a. Maybe a -> Bool
isNothing Maybe Int
expn)
                    (forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"This is an integer, not a floating point number!")
                  let frac' :: Text
frac' = forall a. a -> Maybe a -> a
fromMaybe Text
"" Maybe Text
frac
                      expn' :: Int
expn' = forall a. a -> Maybe a -> a
fromMaybe Int
0 Maybe Int
expn
                  ( forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Fractional a => Rational -> a
fromRational forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. Num a => a -> a -> a
* (Rational
10forall a b. (Fractional a, Integral b) => a -> b -> a
^^(Int
expn' forall a. Num a => a -> a -> a
- forall a b. (Integral a, Num b) => a -> b
fromIntegral (Text -> Int64
T.length Text
frac'))))
                    forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. Integral a => a -> a -> Ratio a
%Integer
1) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Parse a -> Text -> a
runParser' forall a. Integral a => Parse a
parseInt) (Text
ds Text -> Text -> Text
`T.append` Text
frac')
               forall s a. Parser s a -> Parser s a -> Parser s a
`onFail`
               forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"Expected a floating point number"
  where
    parseExp :: Parse Int
parseExp = Char -> Parse Char
character Char
'e'
               forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ((Char -> Parse Char
character Char
'+' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall a. Integral a => Parse a
parseInt)
                   forall s a. Parser s a -> Parser s a -> Parser s a
`onFail`
                   Parse Int
parseSignedInt)
    noDec :: Maybe Text -> Bool
noDec = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True Text -> Bool
T.null

-- Bool indicates whether we can parse values that need quotes.
parseSignedFloat :: Bool -> Parse Double
parseSignedFloat :: Bool -> Parse Double
parseSignedFloat Bool
q = forall a. Num a => Parse a -> Parse a
parseSigned ( forall a. RealFrac a => Bool -> Parse a
parseFloat Bool
q forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Integer -> Double
fI forall a. Integral a => Parse a
parseInt )
  where
    fI :: Integer -> Double
    fI :: Integer -> Double
fI = forall a b. (Integral a, Num b) => a -> b
fromIntegral

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

parseAndSpace   :: Parse a -> Parse a
parseAndSpace :: forall a. Parse a -> Parse a
parseAndSpace Parse a
p = Parse a
p forall (p :: * -> *) a b. PolyParse p => p a -> p b -> p a
`discard` Parser GraphvizState ()
whitespace

string :: String -> Parse ()
string :: [Char] -> Parser GraphvizState ()
string = forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Char -> Parse Char
character

stringRep   :: a -> String -> Parse a
stringRep :: forall a. a -> [Char] -> Parse a
stringRep a
v = forall a. a -> [[Char]] -> Parse a
stringReps a
v forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. Monad m => a -> m a
return

stringReps      :: a -> [String] -> Parse a
stringReps :: forall a. a -> [[Char]] -> Parse a
stringReps a
v [[Char]]
ss = forall (p :: * -> *) a. PolyParse p => [p a] -> p a
oneOf (forall a b. (a -> b) -> [a] -> [b]
map [Char] -> Parser GraphvizState ()
string [[Char]]
ss) forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (m :: * -> *) a. Monad m => a -> m a
return a
v

stringParse :: [(String, Parse a)] -> Parse a
stringParse :: forall a. [([Char], Parse a)] -> Parse a
stringParse = forall a. [([Char], Parse a)] -> Parse a
toPM forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a. Ord a => a -> a -> Ordering
compare forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` forall a b. (a, b) -> a
fst)
  where
    toPM :: [([Char], Parser GraphvizState a)] -> Parser GraphvizState a
toPM = forall (p :: * -> *) a. PolyParse p => [p a] -> p a
oneOf forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map [([Char], Parser GraphvizState a)] -> Parser GraphvizState a
mkPM forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> a -> Bool) -> [a] -> [[a]]
groupBy (forall a. Eq a => a -> a -> Bool
(==) forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (forall a. [a] -> Maybe a
listToMaybe forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst))

    mkPM :: [([Char], Parser GraphvizState a)] -> Parser GraphvizState a
mkPM [([Char]
"",Parser GraphvizState a
p)] = Parser GraphvizState a
p
    mkPM [([Char]
str,Parser GraphvizState a
p)] = [Char] -> Parser GraphvizState ()
string [Char]
str forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser GraphvizState a
p
    mkPM [([Char], Parser GraphvizState a)]
kv = Char -> Parse Char
character (forall a. [a] -> a
head forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ forall a. [a] -> a
head [([Char], Parser GraphvizState a)]
kv) forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> [([Char], Parser GraphvizState a)] -> Parser GraphvizState a
toPM (forall a b. (a -> b) -> [a] -> [b]
map (forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first forall a. [a] -> [a]
tail) [([Char], Parser GraphvizState a)]
kv)

stringValue :: [(String, a)] -> Parse a
stringValue :: forall a. [([Char], a)] -> Parse a
stringValue = forall a. [([Char], Parse a)] -> Parse a
stringParse forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second forall (m :: * -> *) a. Monad m => a -> m a
return)

strings :: [String] -> Parse ()
strings :: [[Char]] -> Parser GraphvizState ()
strings = forall (p :: * -> *) a. PolyParse p => [p a] -> p a
oneOf forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map [Char] -> Parser GraphvizState ()
string

-- | Assumes that any letter is ASCII for case-insensitive
--   comparisons.
character   :: Char -> Parse Char
character :: Char -> Parse Char
character Char
c = forall s. (Char -> Bool) -> Parser s Char
satisfy Char -> Bool
parseC
              forall (p :: * -> *) a.
Commitment p =>
p a -> ([Char] -> [Char]) -> p a
`adjustErr`
              (forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ [Char]
"Not the expected character: " forall a. [a] -> [a] -> [a]
++ [Char
c])
  where
    parseC :: Char -> Bool
parseC Char
c' = Char
c' forall a. Eq a => a -> a -> Bool
== Char
c Bool -> Bool -> Bool
|| Char
c forall a. Eq a => a -> a -> Bool
== Char -> Char
flipCase Char
c'
    flipCase :: Char -> Char
flipCase Char
c' = if Char -> Bool
isLower Char
c'
                  then Char -> Char
toUpper Char
c'
                  else Char -> Char
toLower Char
c'

noneOf   :: [Char] -> Parse Char
noneOf :: [Char] -> Parse Char
noneOf [Char]
t = forall s. (Char -> Bool) -> Parser s Char
satisfy (\Char
x -> forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (forall a. Eq a => a -> a -> Bool
/= Char
x) [Char]
t)

-- | Parses at least one whitespace character.
whitespace1 :: Parse ()
whitespace1 :: Parser GraphvizState ()
whitespace1 = forall s. (Char -> Bool) -> Parser s Text
many1Satisfy Char -> Bool
isSpace forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | Parses zero or more whitespace characters.
whitespace :: Parse ()
whitespace :: Parser GraphvizState ()
whitespace = forall s. (Char -> Bool) -> Parser s Text
manySatisfy Char -> Bool
isSpace forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | Parse and discard optional surrounding whitespace.
wrapWhitespace :: Parse a -> Parse a
wrapWhitespace :: forall a. Parse a -> Parse a
wrapWhitespace = forall (p :: * -> *) bra ket a.
PolyParse p =>
p bra -> p ket -> p a -> p a
bracket Parser GraphvizState ()
whitespace Parser GraphvizState ()
whitespace

optionalQuotedString :: String -> Parse ()
optionalQuotedString :: [Char] -> Parser GraphvizState ()
optionalQuotedString = forall a. Parse a -> Parse a
optionalQuoted forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Parser GraphvizState ()
string

optionalQuoted   :: Parse a -> Parse a
optionalQuoted :: forall a. Parse a -> Parse a
optionalQuoted Parse a
p = forall a. Parse a -> Parse a
quotedParse Parse a
p
                   forall s a. Parser s a -> Parser s a -> Parser s a
`onFail`
                   Parse a
p

quotedParse :: Parse a -> Parse a
quotedParse :: forall a. Parse a -> Parse a
quotedParse = forall (p :: * -> *) bra ket a.
PolyParse p =>
p bra -> p ket -> p a -> p a
bracket Parser GraphvizState ()
parseQuote Parser GraphvizState ()
parseQuote

parseQuote :: Parse ()
parseQuote :: Parser GraphvizState ()
parseQuote = Char -> Parse Char
character Char
quoteChar forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (m :: * -> *) a. Monad m => a -> m a
return ()

orQuote   :: Parse Char -> Parse Char
orQuote :: Parse Char -> Parse Char
orQuote Parse Char
p = forall a. a -> [Char] -> Parse a
stringRep Char
quoteChar [Char]
"\\\""
            forall s a. Parser s a -> Parser s a -> Parser s a
`onFail`
            Parse Char
p

quoteChar :: Char
quoteChar :: Char
quoteChar = Char
'"'

-- | Parse a 'Text' where the provided 'Char's (as well as @\"@ and
--   @\\@) are escaped and the second list of 'Char's are those that
--   are not permitted.  Note: does not parse surrounding quotes.  The
--   'Bool' value indicates whether empty 'Text's are allowed or not.
parseEscaped             :: Bool -> [Char] -> [Char] -> Parse Text
parseEscaped :: Bool -> [Char] -> [Char] -> Parse Text
parseEscaped Bool
empt [Char]
cs [Char]
bnd = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Char] -> Text
T.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a}. Parser GraphvizState a -> Parser GraphvizState [a]
lots forall a b. (a -> b) -> a -> b
$ Parse Char
qPrs forall s a. Parser s a -> Parser s a -> Parser s a
`onFail` forall {s}. Parser s Char
oth
  where
    lots :: Parser GraphvizState a -> Parser GraphvizState [a]
lots = if Bool
empt then forall (f :: * -> *) a. Alternative f => f a -> f [a]
many else forall (p :: * -> *) a. PolyParse p => p a -> p [a]
many1
    cs' :: [Char]
cs' = Char
quoteChar forall a. a -> [a] -> [a]
: Char
slash forall a. a -> [a] -> [a]
: [Char]
cs
    csSet :: Set Char
csSet = forall a. Ord a => [a] -> Set a
Set.fromList [Char]
cs'
    bndSet :: Set Char
bndSet = forall a. Ord a => [a] -> Set a
Set.fromList [Char]
bnd forall a. Ord a => Set a -> Set a -> Set a
`Set.union` Set Char
csSet
    slash :: Char
slash = Char
'\\'
    -- Have to allow standard slashes
    qPrs :: Parse Char
qPrs = forall a. a -> Maybe a -> a
fromMaybe Char
slash
           forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Char -> Parse Char
character Char
slash
                forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (forall (p :: * -> *) a. PolyParse p => [p a] -> p a
oneOf forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Char -> Parse Char
character [Char]
cs')
               )
    oth :: Parser s Char
oth = forall s. (Char -> Bool) -> Parser s Char
satisfy (forall a. Ord a => a -> Set a -> Bool
`Set.notMember` Set Char
bndSet)

-- | Parses a newline.
newline :: Parse ()
newline :: Parser GraphvizState ()
newline = [[Char]] -> Parser GraphvizState ()
strings [[Char]
"\r\n", [Char]
"\n", [Char]
"\r"]

-- | Consume all whitespace and newlines until a line with
--   non-whitespace is reached.  The whitespace on that line is
--   not consumed.
newline' :: Parse ()
newline' :: Parser GraphvizState ()
newline' = forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (Parser GraphvizState ()
whitespace forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser GraphvizState ()
newline) forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | Parses and returns all characters up till the end of the line,
--   but does not touch the newline characters.
consumeLine :: Parse Text
consumeLine :: Parse Text
consumeLine = forall s. (Char -> Bool) -> Parser s Text
manySatisfy (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Char
'\n',Char
'\r'])

parseEq :: Parse ()
parseEq :: Parser GraphvizState ()
parseEq = forall a. Parse a -> Parse a
wrapWhitespace (Char -> Parse Char
character Char
'=') forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | The opposite of 'bracket'.
ignoreSep :: (a -> b -> c) -> Parse a -> Parse sep -> Parse b -> Parse c
ignoreSep :: forall a b c sep.
(a -> b -> c) -> Parse a -> Parse sep -> Parse b -> Parse c
ignoreSep a -> b -> c
f Parse a
pa Parse sep
sep Parse b
pb = a -> b -> c
f forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parse a
pa forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parse sep
sep forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parse b
pb

commaSep :: (ParseDot a, ParseDot b) => Parse (a, b)
commaSep :: forall a b. (ParseDot a, ParseDot b) => Parse (a, b)
commaSep = forall a b. Parse a -> Parse b -> Parse (a, b)
commaSep' forall a. ParseDot a => Parse a
parse forall a. ParseDot a => Parse a
parse

commaSepUnqt :: (ParseDot a, ParseDot b) => Parse (a, b)
commaSepUnqt :: forall a b. (ParseDot a, ParseDot b) => Parse (a, b)
commaSepUnqt = forall a b. Parse a -> Parse b -> Parse (a, b)
commaSep' forall a. ParseDot a => Parse a
parseUnqt forall a. ParseDot a => Parse a
parseUnqt

commaSep'       :: Parse a -> Parse b -> Parse (a,b)
commaSep' :: forall a b. Parse a -> Parse b -> Parse (a, b)
commaSep' Parse a
pa Parse b
pb = forall a b c sep.
(a -> b -> c) -> Parse a -> Parse sep -> Parse b -> Parse c
ignoreSep (,) Parse a
pa (forall a. Parse a -> Parse a
wrapWhitespace Parser GraphvizState ()
parseComma) Parse b
pb

parseComma :: Parse ()
parseComma :: Parser GraphvizState ()
parseComma = Char -> Parse Char
character Char
',' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | Try to parse a list of the specified type; returns an empty list
--   if parsing fails.
tryParseList :: (ParseDot a) => Parse [a]
tryParseList :: forall a. ParseDot a => Parse [a]
tryParseList = forall a. Parse [a] -> Parse [a]
tryParseList' forall a. ParseDot a => Parse a
parse

-- | Return an empty list if parsing a list fails.
tryParseList' :: Parse [a] -> Parse [a]
tryParseList' :: forall a. Parse [a] -> Parse [a]
tryParseList' = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. a -> Maybe a -> a
fromMaybe []) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional

parseAngled :: Parse a -> Parse a
parseAngled :: forall a. Parse a -> Parse a
parseAngled = forall (p :: * -> *) bra ket a.
PolyParse p =>
p bra -> p ket -> p a -> p a
bracket (Char -> Parse Char
character Char
'<') (Char -> Parse Char
character Char
'>')

parseBraced :: Parse a -> Parse a
parseBraced :: forall a. Parse a -> Parse a
parseBraced = forall (p :: * -> *) bra ket a.
PolyParse p =>
p bra -> p ket -> p a -> p a
bracket (Char -> Parse Char
character Char
'{') (Char -> Parse Char
character Char
'}')

-- -----------------------------------------------------------------------------
-- These instances are defined here to avoid cyclic imports and orphan instances

instance ParseDot ColorScheme where
  parseUnqt :: Parse ColorScheme
parseUnqt = Bool -> Parse ColorScheme
parseColorScheme Bool
True

parseColorScheme     :: Bool -> Parse ColorScheme
parseColorScheme :: Bool -> Parse ColorScheme
parseColorScheme Bool
scs = do ColorScheme
cs <- forall (p :: * -> *) a. PolyParse p => [p a] -> p a
oneOf [ forall a. a -> [Char] -> Parse a
stringRep ColorScheme
X11 [Char]
"X11"
                                      , forall a. a -> [Char] -> Parse a
stringRep ColorScheme
SVG [Char]
"svg"
                                      , BrewerScheme -> ColorScheme
Brewer forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. ParseDot a => Parse a
parseUnqt
                                      ]
                          forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
scs forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). GraphvizStateM m => ColorScheme -> m ()
setColorScheme ColorScheme
cs
                          forall (m :: * -> *) a. Monad m => a -> m a
return ColorScheme
cs

instance ParseDot BrewerScheme where
  parseUnqt :: Parse BrewerScheme
parseUnqt = forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 BrewerName -> Word8 -> BrewerScheme
BScheme forall a. ParseDot a => Parse a
parseUnqt forall a. ParseDot a => Parse a
parseUnqt

instance ParseDot BrewerName where
  -- The order is different from above to make sure longer names are
  -- parsed first.
  parseUnqt :: Parse BrewerName
parseUnqt = forall a. [([Char], a)] -> Parse a
stringValue [ ([Char]
"accent", BrewerName
Accent)
                          , ([Char]
"blues", BrewerName
Blues)
                          , ([Char]
"brbg", BrewerName
Brbg)
                          , ([Char]
"bugn", BrewerName
Bugn)
                          , ([Char]
"bupu", BrewerName
Bupu)
                          , ([Char]
"dark2", BrewerName
Dark2)
                          , ([Char]
"gnbu", BrewerName
Gnbu)
                          , ([Char]
"greens", BrewerName
Greens)
                          , ([Char]
"greys", BrewerName
Greys)
                          , ([Char]
"oranges", BrewerName
Oranges)
                          , ([Char]
"orrd", BrewerName
Orrd)
                          , ([Char]
"paired", BrewerName
Paired)
                          , ([Char]
"pastel1", BrewerName
Pastel1)
                          , ([Char]
"pastel2", BrewerName
Pastel2)
                          , ([Char]
"piyg", BrewerName
Piyg)
                          , ([Char]
"prgn", BrewerName
Prgn)
                          , ([Char]
"pubugn", BrewerName
Pubugn)
                          , ([Char]
"pubu", BrewerName
Pubu)
                          , ([Char]
"puor", BrewerName
Puor)
                          , ([Char]
"purd", BrewerName
Purd)
                          , ([Char]
"purples", BrewerName
Purples)
                          , ([Char]
"rdbu", BrewerName
Rdbu)
                          , ([Char]
"rdgy", BrewerName
Rdgy)
                          , ([Char]
"rdpu", BrewerName
Rdpu)
                          , ([Char]
"rdylbu", BrewerName
Rdylbu)
                          , ([Char]
"rdylgn", BrewerName
Rdylgn)
                          , ([Char]
"reds", BrewerName
Reds)
                          , ([Char]
"set1", BrewerName
Set1)
                          , ([Char]
"set2", BrewerName
Set2)
                          , ([Char]
"set3", BrewerName
Set3)
                          , ([Char]
"spectral", BrewerName
Spectral)
                          , ([Char]
"ylgnbu", BrewerName
Ylgnbu)
                          , ([Char]
"ylgn", BrewerName
Ylgn)
                          , ([Char]
"ylorbr", BrewerName
Ylorbr)
                          , ([Char]
"ylorrd", BrewerName
Ylorrd)
                          ]