module Data.GraphViz.ParserCombinators
( module Text.ParserCombinators.Poly.Lazy
, Parse
, Parseable(..)
, stringBlock
, quotedString
, parseAndSpace
, string
, strings
, hasString
, char
, whitespace
, whitespace'
, optionalQuotedString
, optionalQuoted
, quotedParse
, newline
, skipToNewline
, parseField
, parseBoolField
, parseFieldDef
, commaSep
, commaSep'
) where
import Text.ParserCombinators.Poly.Lazy
import Data.Char( digitToInt
, isAsciiLower
, isAsciiUpper
, isDigit
, isSpace
, toLower
)
import Data.Function(on)
import Data.Maybe(isJust)
import Data.Ratio((%))
import Control.Monad
type Parse a = Parser Char a
class Parseable a where
parse :: Parse a
parseList :: Parse [a]
parseList = oneOf [ char '[' >> whitespace' >> char ']' >> return []
, bracketSep (parseAndSpace $ char '[')
(parseAndSpace $ char ',')
(parseAndSpace $ char ']')
(parseAndSpace parse)
]
instance Parseable Int where
parse = parseInt
instance Parseable Double where
parse = parseSigned parseFloat
instance Parseable Bool where
parse = oneOf [ string "true" >> return True
, string "false" >> return False
, liftM (zero /=) parseInt
]
where
zero :: Int
zero = 0
instance Parseable Char where
parse = next
parseList = oneOf [ stringBlock
, quotedString
]
instance (Parseable a) => Parseable [a] where
parse = parseList
stringBlock :: Parse String
stringBlock = do frst <- satisfy frstCond
rest <- many (satisfy restCond)
return $ frst : rest
where
frstCond c = any ($c) [ isAsciiUpper
, isAsciiLower
, (==) '_'
, \ x -> x >= '\200' && x <= '\377'
]
restCond c = frstCond c || isDigit c
quotedString :: Parse String
quotedString = do w <- word
if head w == '"'
then return w
else fail $ "Not a quoted string: " ++ w
word :: Parse String
word = P (\s-> case lex s of
[] -> Failure s "no input? (impossible)"
[("","")] -> Failure "" "no input?"
[("",s')] -> Failure s' "lexing failed?"
((x,s'):_) -> Success s' x
)
parseSigned :: Real a => Parse a -> Parse a
parseSigned p = do '-' <- next; commit (fmap 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
parseFloat :: (RealFrac a) => Parse a
parseFloat = do ds <- many1 (satisfy isDigit)
frac <- (do '.' <- next
many (satisfy isDigit)
`adjustErrBad` (++"expected digit after .")
`onFail` return [] )
expn <- parseExp `onFail` return 0
( return . fromRational . (* (10^^(expn length frac)))
. (%1) . fst
. runParser parseInt) (ds++frac)
`onFail`
do w <- many (satisfy (not.isSpace))
case map toLower w of
"nan" -> return (0/0)
"infinity" -> return (1/0)
_ -> fail "expected a floating point number"
where parseExp = do 'e' <- fmap toLower next
commit (do '+' <- next; parseInt
`onFail`
parseSigned parseInt)
parseAndSpace :: Parse a -> Parse a
parseAndSpace p = p `discard` whitespace'
string :: String -> Parse String
string = mapM char
strings :: [String] -> Parse String
strings = oneOf . map string
hasString :: String -> Parse Bool
hasString = liftM isJust . optional . string
char :: Char -> Parse Char
char c = satisfy (((==) `on` toLower) c)
`adjustErr`
(++ "\nnot the expected char: " ++ [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)
optionalQuotedString :: String -> Parse String
optionalQuotedString = optionalQuoted . string
optionalQuoted :: Parse a -> Parse a
optionalQuoted p = oneOf [ p
, quotedParse p
]
quotedParse :: Parse a -> Parse a
quotedParse p = char '"' >> p `discard` char '"'
newline :: Parse String
newline = oneOf . map string $ ["\r\n", "\n", "\r"]
skipToNewline :: Parse ()
skipToNewline = many (noneOf ['\n','\r']) >> newline >> return ()
parseField :: (Parseable a) => String -> Parse a
parseField fld = do string fld
whitespace'
char '='
whitespace'
parse
parseBoolField :: String -> Parse Bool
parseBoolField = parseFieldDef True
parseFieldDef :: (Parseable a) => a -> String -> Parse a
parseFieldDef d fld = oneOf [ parseField fld
, string fld >> return d
]
commaSep :: (Parseable a, Parseable b) => Parse (a, b)
commaSep = commaSep' parse parse
commaSep' :: Parse a -> Parse b -> Parse (a,b)
commaSep' pa pb = do a <- pa
whitespace'
char ','
whitespace'
b <- pb
return (a,b)