module Data.GraphViz.Parsing
(
module Text.ParserCombinators.Poly.Lazy
, Parse
, ParseDot(..)
, parseIt
, parseIt'
, runParser'
, bracket
, discard
, onlyBool
, quotelessString
, stringBlock
, numString
, isNumString
, isIntString
, quotedString
, parseEscaped
, parseAndSpace
, string
, strings
, character
, parseStrictFloat
, noneOf
, whitespace
, whitespace'
, allWhitespace
, allWhitespace'
, wrapWhitespace
, optionalQuotedString
, optionalQuoted
, quotedParse
, orQuote
, quoteChar
, newline
, newline'
, parseComma
, parseEq
, tryParseList
, tryParseList'
, consumeLine
, parseField
, parseFields
, parseFieldBool
, parseFieldsBool
, parseFieldDef
, parseFieldsDef
, commaSep
, commaSepUnqt
, commaSep'
, stringRep
, stringReps
, parseAngled
, parseBraced
) where
import Data.GraphViz.Util
import Text.ParserCombinators.Poly.Lazy hiding (bracket, discard)
import Data.Char( digitToInt
, isDigit
, isSpace
, toLower
)
import Data.Maybe(fromMaybe, isNothing)
import Data.Ratio((%))
import qualified Data.Set as Set
import Data.Word(Word8, Word16)
import Control.Monad(liftM, when)
type Parse a = Parser Char a
runParser' :: Parse a -> String -> a
runParser' p = fst . runParser p'
where
p' = p `discard` (allWhitespace' >> eof)
class ParseDot a where
parseUnqt :: Parse a
parse :: Parse a
parse = optionalQuoted parseUnqt
parseUnqtList :: Parse [a]
parseUnqtList = bracketSep (parseAndSpace $ character '[')
( wrapWhitespace parseComma
`onFail`
allWhitespace
)
(allWhitespace' >> character ']')
parseUnqt
parseList :: Parse [a]
parseList = quotedParse parseUnqtList
parseIt :: (ParseDot a) => String -> (a, String)
parseIt = runParser parse
parseIt' :: (ParseDot a) => String -> a
parseIt' = runParser' parse
instance ParseDot Int where
parseUnqt = parseInt'
instance ParseDot Word8 where
parseUnqt = parseInt
instance ParseDot Word16 where
parseUnqt = parseInt
instance ParseDot Double where
parseUnqt = parseFloat'
parseUnqtList = sepBy1 parseUnqt (character ':')
parseList = quotedParse parseUnqtList
`onFail`
liftM return parse
instance ParseDot Bool where
parseUnqt = onlyBool
`onFail`
liftM (zero /=) parseInt'
where
zero :: Int
zero = 0
onlyBool :: Parse Bool
onlyBool = oneOf [ stringRep True "true"
, stringRep False "false"
]
instance ParseDot Char where
parseUnqt = satisfy (quoteChar /=)
parse = satisfy restIDString
`onFail`
quotedParse parseUnqt
parseUnqtList = quotedString
parseList = quotelessString
`onFail`
quotedParse quotedString
instance (ParseDot a) => ParseDot [a] where
parseUnqt = parseUnqtList
parse = parseList
quotelessString :: Parse String
quotelessString = numString `onFail` stringBlock
numString :: Parse String
numString = liftM show parseStrictFloat
`onFail`
liftM show parseInt'
stringBlock :: Parse String
stringBlock = do frst <- satisfy frstIDString
rest <- many (satisfy restIDString)
return $ frst : rest
quotedString :: Parse String
quotedString = parseEscaped True []
parseSigned :: Real a => Parse a -> Parse a
parseSigned p = (character '-' >> liftM negate p)
`onFail`
p
parseInt :: (Integral a) => Parse a
parseInt = do cs <- many1 (satisfy isDigit)
return (foldl1 (\n d-> n*radix+d)
(map (fromIntegral . digitToInt) cs))
`adjustErr` (++ "\nexpected one or more digits")
where
radix = 10
parseInt' :: Parse Int
parseInt' = parseSigned parseInt
parseStrictFloat :: Parse Double
parseStrictFloat = parseSigned parseFloat
parseFloat :: (RealFrac a) => Parse a
parseFloat = do ds <- many (satisfy isDigit)
frac <- optional
$ do character '.'
many (satisfy isDigit)
when (null ds && noDec frac)
(fail "No actual digits in floating point number!")
expn <- optional parseExp
when (isNothing frac && isNothing expn)
(fail "This is an integer, not a floating point number!")
let frac' = fromMaybe "" frac
expn' = fromMaybe 0 expn
( return . fromRational . (* (10^^(expn' length frac')))
. (%1) . runParser' parseInt) (ds++frac')
`onFail`
fail "Expected a floating point number"
where
parseExp = do character 'e'
((character '+' >> parseInt)
`onFail`
parseInt')
noDec = maybe True null
parseFloat' :: Parse Double
parseFloat' = parseSigned ( parseFloat
`onFail`
liftM fI parseInt
)
where
fI :: Integer -> Double
fI = fromIntegral
bracket :: Parse bra -> Parse ket -> Parse a -> Parse a
bracket open close pa = do open `adjustErr` ("Missing opening bracket:\n\t"++)
pa `discard`
(close
`adjustErr` ("Missing closing bracket:\n\t"++))
infixl 3 `discard`
discard :: Parse a -> Parse b -> Parse a
pa `discard` pb = do a <- pa
pb
return a
parseAndSpace :: Parse a -> Parse a
parseAndSpace p = p `discard` allWhitespace'
string :: String -> Parse String
string = mapM character
stringRep :: a -> String -> Parse a
stringRep v = stringReps v . return
stringReps :: a -> [String] -> Parse a
stringReps v ss = oneOf (map string ss) >> return v
strings :: [String] -> Parse String
strings = oneOf . map string
character :: Char -> Parse Char
character c = satisfy parseC
`adjustErr`
(++ "\nnot the expected char: " ++ [c])
where
parseC c' = c' == c || toLower c == c'
noneOf :: (Eq a) => [a] -> Parser a a
noneOf t = satisfy (\x -> all (/= x) t)
whitespace :: Parse String
whitespace = many1 (satisfy isSpace)
whitespace' :: Parse String
whitespace' = many (satisfy isSpace)
allWhitespace :: Parse ()
allWhitespace = (whitespace `onFail` newline) >> allWhitespace'
allWhitespace' :: Parse ()
allWhitespace' = newline' `discard` whitespace'
wrapWhitespace :: Parse a -> Parse a
wrapWhitespace = bracket allWhitespace' allWhitespace'
optionalQuotedString :: String -> Parse String
optionalQuotedString = optionalQuoted . string
optionalQuoted :: Parse a -> Parse a
optionalQuoted p = quotedParse p
`onFail`
p
quotedParse :: Parse a -> Parse a
quotedParse = bracket parseQuote parseQuote
parseQuote :: Parse Char
parseQuote = character quoteChar
orQuote :: Parse Char -> Parse Char
orQuote p = stringRep quoteChar "\\\""
`onFail`
p
quoteChar :: Char
quoteChar = '"'
parseEscaped :: Bool -> [Char] -> Parse String
parseEscaped empt cs = lots $ qPrs `onFail` oth
where
lots = if empt then many else many1
cs' = quoteChar : cs
csSet = Set.fromList cs'
slash = '\\'
qPrs = do character slash
mE <- optional $ oneOf (map character cs')
return $ fromMaybe slash mE
oth = satisfy (`Set.notMember` csSet)
newline :: Parse String
newline = oneOf $ map string ["\r\n", "\n", "\r"]
newline' :: Parse ()
newline' = many (whitespace' >> newline) >> return ()
consumeLine :: Parse String
consumeLine = many (noneOf ['\n','\r'])
parseEq :: Parse ()
parseEq = wrapWhitespace (character '=') >> return ()
parseField :: (ParseDot a) => (a -> b) -> String -> Parse b
parseField c fld = do string fld
parseEq
liftM c parse
parseFields :: (ParseDot a) => (a -> b) -> [String] -> Parse b
parseFields c = oneOf . map (parseField c)
parseFieldBool :: (Bool -> b) -> String -> Parse b
parseFieldBool = flip parseFieldDef True
parseFieldsBool :: (Bool -> b) -> [String] -> Parse b
parseFieldsBool c = oneOf . map (parseFieldBool c)
parseFieldDef :: (ParseDot a) => (a -> b) -> a -> String -> Parse b
parseFieldDef c d fld = parseField c fld
`onFail`
do string fld
nxt <- optional $ satisfy restIDString
bool (fail "Not actually the field you were after")
(return $ c d)
(isNothing nxt)
parseFieldsDef :: (ParseDot a) => (a -> b) -> a -> [String] -> Parse b
parseFieldsDef c d = oneOf . map (parseFieldDef c d)
commaSep :: (ParseDot a, ParseDot b) => Parse (a, b)
commaSep = commaSep' parse parse
commaSepUnqt :: (ParseDot a, ParseDot b) => Parse (a, b)
commaSepUnqt = commaSep' parseUnqt parseUnqt
commaSep' :: Parse a -> Parse b -> Parse (a,b)
commaSep' pa pb = do a <- pa
whitespace'
parseComma
whitespace'
b <- pb
return (a,b)
parseComma :: Parse ()
parseComma = character ',' >> return ()
tryParseList :: (ParseDot a) => Parse [a]
tryParseList = tryParseList' parse
tryParseList' :: Parse [a] -> Parse [a]
tryParseList' = liftM (fromMaybe []) . optional
parseAngled :: Parse a -> Parse a
parseAngled = bracket (character '<') (character '>')
parseBraced :: Parse a -> Parse a
parseBraced = bracket (character '{') (character '}')