{- 
 
   Parser.hs: Parser for the Flounder interface definition language
                      
   Part of Flounder: a strawman device definition DSL for Barrelfish
   
  Copyright (c) 2009, ETH Zurich.

  All rights reserved.
  
  This file is distributed under the terms in the attached LICENSE file.
  If you do not find this file, copies can be found by writing to:
  ETH Zurich D-INFK, Haldeneggsteig 4, CH-8092 Zurich. Attn: Systems Group.
-}
  
module Parser where

import FuguBackend

import Text.ParserCombinators.Parsec as Parsec
import Text.ParserCombinators.Parsec.Expr
import Text.ParserCombinators.Parsec.Pos
import qualified Text.ParserCombinators.Parsec.Token as P
import Text.ParserCombinators.Parsec.Language( javaStyle )
import Data.Char
import Numeric
import Data.List
import Text.Printf

parse filename = parseFromFile errorFile filename
                      
lexer = P.makeTokenParser (javaStyle
                           { P.reservedNames = [ "errors", 
                                                 "success",
                                                 "failure"
                                               ]
                           , P.reservedOpNames = ["*","/","+","-"]
                           , P.commentStart = "/*"
                           , P.commentEnd = "*/"
                           , P.commentLine = "//"
                           })

whiteSpace = P.whiteSpace lexer 
reserved   = P.reserved lexer
identifier = P.identifier lexer
stringLit  = P.stringLiteral lexer
comma      = P.comma lexer
commaSep   = P.commaSep lexer
commaSep1  = P.commaSep1 lexer
parens     = P.parens lexer
braces     = P.braces lexer
squares    = P.squares lexer
semiSep    = P.semiSep lexer
symbol     = P.symbol lexer


errorFile = 
    do 
      whiteSpace
      errors <- many1 errorClass
      return errors


errorClass = 
    do 
      reserved "errors"
      name <- identifier
      classE <- identifier
      errors <- braces $ many1 (errorCase classE)
      symbol ";" <?> " ';' missing from end of " ++ name ++ " error definition"
      return $ ErrorClass name errors

errorCase classE =
    do
      successCase classE
      <|> (failureCase classE)
      <|> (defaultSuccessCase classE)
  
defaultSuccessCase classE =
    do
      reserved "default"
      (ErrorField _ name descr) <- successCase classE
      return $ ErrorField DefaultSuccess name descr

successCase classE =
    do
      reserved "success"
      acronym <- identifier
      description <- stringLit
      symbol "," <?> " ',' missing from end of " ++ acronym ++ " definition"
      return $ ErrorField Success (classE ++ acronym) description

failureCase classE =
    do
      reserved "failure"
      acronym <- identifier
      description <- stringLit
      symbol "," <?> " ',' missing from end of " ++ acronym ++ " definition"
      return $ ErrorField Failure (classE ++ acronym) description