diff options
| -rw-r--r-- | src/Grasp/Parser.hs | 141 |
1 files changed, 71 insertions, 70 deletions
diff --git a/src/Grasp/Parser.hs b/src/Grasp/Parser.hs index 06d4b59..8c0e4b4 100644 --- a/src/Grasp/Parser.hs +++ b/src/Grasp/Parser.hs @@ -4,17 +4,17 @@ module Grasp.Parser ( import Control.Applicative( some ) +import Data.Char( toLower, toUpper ) import Text.ParserCombinators.Parsec -import qualified Grasp.Graph as G +import Grasp.Types( Instruction(..), EdgeLabel(..), GNode(..), GEdge(..) ) -parseGrasp :: String -> Either ParseError GraspProgram +parseGrasp :: String -> Either ParseError ([GNode],[GEdge]) parseGrasp input = - parse removeComments "error" input >>= - parse graspDOT "error" >>= - return . G.construct + parse removeComments "error" input >>= + parse graspDOT "error" @@ -42,29 +42,30 @@ thing = try (some (noneOf "\r\n\"/#")) singleLineComment = - (string "//" >> many (noneOf "\r\n") >> return "") - <|> (string "#" >> many (noneOf "\r\n") >> return "") + (string "//" >> many (noneOf "\r\n") >> return "") + <|> (string "#" >> many (noneOf "\r\n") >> return "") multiLineComment = do - string "/*" - many (noneOf "*" <|> (char '*' >> notFollowedBy (char '/') >> return '*')) - return "" + string "/*" + many (noneOf "*" <|> (char '*' >> notFollowedBy (char '/') >> return '*')) + string "*/" + return "" -- parses a DOT graph language file into the data for a grasp program graspDOT = do - optional strict - graphType - optional ident - openBrace - (n,e) <- stmtList ([],[]) - closeBrace - many blankLine - eof - return (n,e) + optional strict + graphType + optional ident + openBrace + (n,e) <- stmtList ([],[]) + closeBrace + many blankLine + eof + return (n,e) strict = caseInsensitiveString "strict" >>= (\x -> whiteSpace >> return x) @@ -80,21 +81,21 @@ ident = ((try alphaNumString) stmtList (n,e) = - try (whiteSpace >> node >>= (\x -> stmtList (x:n,e)) ) - <|> try (whiteSpace >> edge >>= (\x -> stmtList (n,x:e)) ) - <|> try (whiteSpace >> attr >> stmtList (n,e)) - <|> try (whiteSpace >> subgraph >>= (\(x,y) -> stmtList ((reverse x) ++ n, (reverse y) ++ e)) ) - <|> try (blankLine >> stmtList (n,e)) - <|> return (reverse n, reverse e) + try (whiteSpace >> node >>= (\x -> stmtList (x:n,e)) ) + <|> try (whiteSpace >> edge >>= (\x -> stmtList (n,x:e)) ) + <|> try (whiteSpace >> attr >> stmtList (n,e)) + <|> try (whiteSpace >> subgraph >>= (\(x,y) -> stmtList ((reverse x) ++ n, (reverse y) ++ e)) ) + <|> try (blankLine >> stmtList (n,e)) + <|> return (reverse n, reverse e) blankLine = whiteSpace >> eol alphaNumString = do - a <- nonDigitChar - b <- many alphaNumChar - return (a:b) + a <- nonDigitChar + b <- many alphaNumChar + return (a:b) nonDigitChar = letter <|> char '_' @@ -110,31 +111,31 @@ floatNum = do { a <- some digit; char '.'; b <- many digit; return (a ++ "." ++ quotedString = do - char '\"' - s <- some quotedChar - char '\"' - return s + char '\"' + s <- some quotedChar + char '\"' + return s quotedChar = noneOf "\"\r\n" <|> try (char '\\' >> char '\"') node = do - n <- ident - a <- attrList - optional (char ';') - whiteSpace - return (n,a) + n <- ident + a <- attrList + optional (char ';') + whiteSpace + return (GNode (n, Instruction a)) edge = do - a <- ident - edgeOp - b <- ident - c <- attrList - optional (char ';') - whiteSpace - return (a,b,c) + a <- ident + edgeOp + b <- ident + c <- attrList + optional (char ';') + whiteSpace + return (GEdge (a,b, EdgeLabel c)) edgeOp = string "->" >> whiteSpace >> return "->" @@ -147,44 +148,44 @@ attrType = (caseInsensitiveString "graph" attrList = do - a <- many aList - let r = filter (\x -> fst x == "label") (concat a) - case (length r) of - 0 -> fail "expected node/edge label" - 1 -> return . snd . head $ r - _ -> fail "unexpected multiple labels for single node/edge" + a <- many aList + let r = filter (\x -> fst x == "label") (concat a) + case (length r) of + 0 -> fail "expected node/edge label" + 1 -> return . snd . head $ r + _ -> fail "unexpected multiple labels for single node/edge" aList = do - openBracket - a <- many equAttr - closeBracket - whiteSpace - return a + openBracket + a <- many equAttr + closeBracket + whiteSpace + return a equAttr = do - e <- equ - optional (char ';' <|> char ',') - whiteSpace - return e + e <- equ + optional (char ';' <|> char ',') + whiteSpace + return e equ = do - a <- ident - equalsChar - b <- ident - return (a,b) + a <- ident + equalsChar + b <- ident + return (a,b) subgraph = do - optional (caseInsensitiveString "subgraph" >> optional ident) - openBrace - (n,e) <- stmtList ([],[]) - closeBrace - optional (char ';') - whiteSpace - return (n,e) + optional (caseInsensitiveString "subgraph" >> optional ident) + openBrace + (n,e) <- stmtList ([],[]) + closeBrace + optional (char ';') + whiteSpace + return (n,e) openBrace = char '{' >> whiteSpace >> return '{' |