module Grasp.Parser (
    parseGrasp
    ) where




import Control.Applicative( some )
import Data.Char( toLower, toUpper )
import Text.ParserCombinators.Parsec

import Grasp.Types.GNode( GNode )
import qualified Grasp.Types.GNode as GN

import Grasp.Types.GEdge( GEdge )
import qualified Grasp.Types.GEdge as GE

import Grasp.Types.Instruction( Instruction )
import qualified Grasp.Types.Instruction as IN

import Grasp.Types.EdgeLabel( EdgeLabel )
import qualified Grasp.Types.EdgeLabel as EL




parseGrasp :: String -> Either ParseError ([GNode],[GEdge])
parseGrasp input =
    parse removeComments "error" input >>=
    parse graspDOT "error"




-- removes comments but otherwise leaves input unchanged

removeComments = gline `sepEndBy` eol >>= return . concat


eol  =  try (string "\r\n")
    <|> try (string "\n\r")
    <|> try (string "\n")
    <|> try (string "\r")
    <?> "end of line"


gline = many thing >>= return . concat


thing = try (some (noneOf "\r\n\"/#"))
    <|> try (quotedString >>= return . ("\"" ++) . (++ "\""))
    <|> try singleLineComment
    <|> try multiLineComment
    <|> (anyChar >>= return . (:[]) )


singleLineComment =
        (string "//" >> many (noneOf "\r\n") >> return "")
    <|> (string "#" >> many (noneOf "\r\n") >> return "")


multiLineComment = do
    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)


strict = caseInsensitiveString "strict" >>= (\x -> whiteSpace >> return x)


graphType = try (caseInsensitiveString "digraph" >>= (\x -> whiteSpace >> return x)) <?> "digraph"


ident = ((try alphaNumString)
    <|>  (try numeral)
    <|>  (try quotedString)) >>= (\x -> whiteSpace >> return x)
    <?> "ID"


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)


blankLine = whiteSpace >> eol


alphaNumString = do
    a <- nonDigitChar
    b <- many alphaNumChar
    return (a:b)


nonDigitChar = letter <|> char '_'
alphaNumChar = alphaNum <|> char '_'


numeral = try negativeNum <|> positiveNum
negativeNum = char '-' >> positiveNum >>= return . ('-':)
positiveNum = try pointNum <|> try floatNum <|> wholeNum
pointNum = char '.' >> some digit >>= return . ('.':)
wholeNum = some digit
floatNum = do { a <- some digit; char '.'; b <- many digit; return (a ++ "." ++ b)}


quotedString = do
    char '\"'
    s <- some quotedChar
    char '\"'
    return s


quotedChar = noneOf "\"\r\n" <|> try (char '\\' >> char '\"')


node = do
    n <- ident
    a <- attrList
    optional (char ';')
    whiteSpace
    return (GN.mk (n, IN.mk a))


edge = do
    a <- ident
    edgeOp
    b <- ident
    c <- attrList
    optional (char ';')
    whiteSpace
    return (GE.mk (a,b, EL.mk c))


edgeOp = string "->" >> whiteSpace >> return "->"


attr = attrType >> attrList >> optional (char ';') >> whiteSpace
attrType = (caseInsensitiveString "graph"
        <|> caseInsensitiveString "node"
        <|> caseInsensitiveString "edge") >>= (\x -> whiteSpace >> return x)


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"


aList = do
    openBracket
    a <- many equAttr
    closeBracket
    whiteSpace
    return a


equAttr = do
    e <- equ
    optional (char ';' <|> char ',')
    whiteSpace
    return e


equ = do
    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)


openBrace = char '{' >> whiteSpace >> return '{'
closeBrace = char '}' >> whiteSpace >> return '}'
openBracket = char '[' >> whiteSpace >> return '['
closeBracket = char ']' >> whiteSpace >> return ']'
equalsChar = char '='


caseInsensitiveChar c = char (toLower c) <|> char (toUpper c)
caseInsensitiveString s = mapM caseInsensitiveChar s


whiteSpace = many (oneOf " \t")