{
-- Parser for the small language Epsilon
-- $Id: EpsilonParser.y,v 1.3 2007/02/21 00:52:10 cs162 Exp $

module EpsilonParser where
import Char
}

%name parser
%tokentype { Token }

%token
      procedure    { TokenProcedure }
      function     { TokenFunction }
      begin    	   { TokenBegin }
      end    	   { TokenEnd }
      while  	   { TokenWhile }
      do	   { TokenDo }
      if	   { TokenIf }
      then	   { TokenThen }
      else	   { TokenElse }
      write	   { TokenWrite }
      read	   { TokenRead }
      return	   { TokenReturn }
      odd	   { TokenOdd }
      var	   { TokenVar }
      '!='	   { TokenNEQ }
      '<'	   { TokenLT }
      '>'	   { TokenGT }
      '<='	   { TokenLEQ }
      '>='	   { TokenGEQ }
      ':='	   { TokenAssign }
      '='    	   { TokenEq }
      '+'    	   { TokenPlus }
      '*'    	   { TokenTimes }
      '/'    	   { TokenDiv }
      '('    	   { TokenOP }
      ')'    	   { TokenCP }
      ';'	   { TokenSemicolon }
      ','	   { TokenComma }
      '.'	   { TokenPeriod }
      '['	   { TokenOB }
      ']'	   { TokenCB }
      '-'    	   { TokenMinus }
      ident	   { TokenIdent $$ }
      int	   { TokenInt $$ }

%left '+' '-'
%left '*' '/'

%nonassoc then
%nonassoc else

%%

Program		: DeclList CompoundStmt '.'	{ Program $1 $2 }
		| CompoundStmt '.' { Program [] $1 }

DeclList	: DeclList Declaration { $1 ++ [$2] }
		| Declaration { [$1] }

Declaration	: Vars { $1 }
		| Proc { $1 }

Proc		: Head ';' Body ';' { Proc $1 $3 }

Head		: procedure ident FormalParams { ProcedureHead $2 $3 }
                | function ident FormalParams { FunctionHead $2 $3 }

FormalParams	: '(' IdentList ')' { $2 }
		| '(' ')' { [] }

Body		: Vars CompoundStmt { Body $1 $2 }
		| CompoundStmt { Body (VarDecl []) $1  }

CompoundStmt	: begin Statements end { CompoundStatement $2 }

IdentList	: IdentDecl { [$1] }
		| IdentDecl ',' IdentList { $1 : $3 }

Vars		: var IdentList ';' { VarDecl $2 }

Statements	: Statements ';' Statement { $1 ++ [$3] }
		| Statement { [$1] }

Statement	: IdentExpr ':=' Expression { Assignment $1 $3 }
		| ident ActualParams { ProcedureCall $1 $2 }
		| if Condition then Statement { If $2 $4 }
		| if Condition then Statement else Statement { IfElse $2 $4 $6 }
		| while Condition do Statement { While $2 $4 }
		| write Expression { Write $2 }
		| read Expression { Read $2 }
		| return Expression { Return $2 }
		| CompoundStmt { $1 }

ActualParams	: '(' ParamList ')' { $2 }
		| '(' ')' { [] }

ParamList	: IdentExpr { [$1] }
		| IdentExpr ',' ParamList { $1 : $3 }

Condition	: odd Expression { Odd $2 }
		| Expression '=' Expression { Equal $1 $3 }
		| Expression '!=' Expression { NotEqual $1 $3}
		| Expression '<' Expression { LessThan $1 $3 }
		| Expression '>' Expression { GreaterThan $1 $3 }
		| Expression '<=' Expression { LessEqual $1 $3 }
		| Expression '>=' Expression { GreaterEqual $1 $3 }

Expression	: Expression '+' Expression { Addition $1 $3 }
		| Expression '-' Expression { Subtraction $1 $3 }
		| Expression '*' Expression { Multiplication $1 $3 }
		| Expression '/' Expression { Division $1 $3 }
		| '-' Expression { Negation $2 }
		| '(' Expression ')' { $2 }
		| ident ActualParams { FunctionCall $1 $2 }
		| IdentExpr { $1 }
		| int { Integer $1 }

IdentExpr	: ident '[' Expression ']' { ArrayIdentExpr $1 $3 }
		| ident { NonArrayIdentExpr $1 }

IdentDecl	: ident '[' int ']' { ArrayIdentDecl $1 $3 }
		| ident { NonArrayIdentDecl $1 }

{

data ParseTree
     = Program [Declaration] ParseTree
     | VarDecl [IdentDecl]
     | Proc Head Body
     | ArrayIdentDecl String Int
     | NonArrayIdentDecl String
     | CompoundStatement [Statement]
     | Assignment Expression Expression
     | ProcedureCall String [Expression]
     | If Condition Statement
     | IfElse Condition Statement Statement
     | Write Expression
     | Read Expression
     | Return Expression
     | While Condition Statement
     | Odd Expression
     | Equal Expression Expression
     | NotEqual Expression Expression
     | LessThan Expression Expression
     | GreaterThan Expression Expression
     | LessEqual Expression Expression
     | GreaterEqual Expression Expression
     | Integer Int
     | NonArrayIdentExpr String
     | ArrayIdentExpr String Expression
     | Addition Expression Expression
     | Subtraction Expression Expression
     | Multiplication Expression Expression
     | Division Expression Expression
     | Negation Expression
     | FunctionCall String [Expression]
     | Body Declaration Statement
     | ProcedureHead String [IdentDecl]
     | FunctionHead String [IdentDecl]
     | Identifier String
      deriving Show

type Declaration = ParseTree
type IdentDecl = ParseTree
type Statement = ParseTree
type Condition = ParseTree
type Expression = ParseTree
type Body = ParseTree
type Head = ParseTree

children :: ParseTree -> [ParseTree]
children (Program d s) = d ++ [s]
children (VarDecl d) = d
children (Proc h b) = [h, b]
children (ArrayIdentDecl id ix) = [(Identifier id), (Integer ix)]
children (NonArrayIdentDecl id) = [(Identifier id)]
children (CompoundStatement s) = s
children (Assignment a b) = [a, b]
children (ProcedureCall id args) = (Identifier id) : args
children (If cond stmt) = [cond, stmt]
children (IfElse cond s1 s2) = [cond, s1, s2]
children (Write expr) = [expr]
children (Read expr) = [expr]
children (Return expr) = [expr]
children (While cond s) = [cond, s]
children (Odd expr) = [expr]
children (Equal e1 e2) = [e1, e2]
children (NotEqual e1 e2) = [e1, e2]
children (LessThan e1 e2) = [e1, e2]
children (GreaterThan e1 e2) = [e1, e2]
children (LessEqual e1 e2) = [e1, e2]
children (GreaterEqual e1 e2) = [e1, e2]
children (Integer i) = [(Integer i)]
children (NonArrayIdentExpr id) = [(Identifier id)]
children (ArrayIdentExpr id ix) = [(Identifier id), ix]
children (Addition e1 e2) = [e1, e2]
children (Subtraction e1 e2) = [e1, e2]
children (Multiplication e1 e2) = [e1, e2]
children (Division e1 e2) = [e1, e2]
children (Negation e) = [e]
children (FunctionCall id args) = (Identifier id) : args
children (Body decl s) = [decl, s]
children (ProcedureHead id args) = (Identifier id) : args
children (FunctionHead id args) = (Identifier id) : args

nodeName :: ParseTree -> String
nodeName (Program d s) = "Program"
nodeName (VarDecl d) = "VarDecl"
nodeName (Proc h b) = "Proc"
nodeName (ArrayIdentDecl id ix) = "ArrayIdentDecl"
nodeName (NonArrayIdentDecl id) = "NonArrayIdentDecl"
nodeName (CompoundStatement s) = "CompoundStatement"
nodeName (Assignment a b) = "Assignment"
nodeName (ProcedureCall id args) = "ProcedureCall"
nodeName (If cond stmt) = "If"
nodeName (IfElse cond s1 s2) = "IfElse"
nodeName (Write expr) = "Write"
nodeName (Read expr) = "Read"
nodeName (Return expr) = "Return"
nodeName (While cond s) = "While"
nodeName (Odd expr) = "Odd"
nodeName (Equal e1 e2) = "Equal"
nodeName (NotEqual e1 e2) = "NotEqual"
nodeName (LessThan e1 e2) = "LessThan"
nodeName (GreaterThan e1 e2) = "GreaterThan"
nodeName (LessEqual e1 e2) = "LessEqual"
nodeName (GreaterEqual e1 e2) = "GreaterEqual"
nodeName (Integer i) = "Integer"
nodeName (NonArrayIdentExpr id) = "NonArrayIdentExpr"
nodeName (ArrayIdentExpr id ix) = "ArrayIdentExpr"
nodeName (Addition e1 e2) = "Addition"
nodeName (Subtraction e1 e2) = "Subtraction"
nodeName (Multiplication e1 e2) = "Multiplication"
nodeName (Division e1 e2) = "Division"
nodeName (Negation e) = "Negation"
nodeName (FunctionCall id args) = "FunctionCall"
nodeName (Body decl s) = "Body"
nodeName (ProcedureHead id args) = "ProcedureHead"
nodeName (FunctionHead id args) = "FunctionHead"

happyError :: [Token] -> a
happyError _ = error "Parse error"

data Token
      = TokenProcedure
      | TokenFunction
      | TokenBegin
      | TokenEnd
      | TokenWhile
      | TokenDo
      | TokenIf
      | TokenThen
      | TokenElse
      | TokenWrite
      | TokenRead
      | TokenReturn
      | TokenOdd
      | TokenVar
      | TokenNEQ
      | TokenLT
      | TokenGT
      | TokenLEQ
      | TokenGEQ
      | TokenAssign
      | TokenEq
      | TokenPlus
      | TokenTimes
      | TokenDiv
      | TokenOP
      | TokenCP
      | TokenSemicolon
      | TokenComma
      | TokenPeriod
      | TokenOB
      | TokenCB
      | TokenMinus
      | TokenIdent String
      | TokenInt Int
 deriving Show

lexer :: Int -> String -> [Token]
lexer line [] = []
lexer line (c:cs) 
      | isSpace c = lexer line cs
      | isAlpha c = lexIdent line (c:cs)
      | isDigit c = lexNum line (c:cs)
lexer line ('\n':cs) = lexer (line + 1) cs
lexer line ('=':cs) = TokenEq : lexer line cs
lexer line ('+':cs) = TokenPlus : lexer line cs
lexer line ('*':cs) = TokenTimes : lexer line cs
lexer line ('/':cs) = TokenDiv : lexer line cs
lexer line ('(':cs) = TokenOP : lexer line cs
lexer line (')':cs) = TokenCP : lexer line cs
lexer line (';':cs) = TokenSemicolon : lexer line cs
lexer line (',':cs) = TokenComma : lexer line cs
lexer line ('.':cs) = TokenPeriod : lexer line cs
lexer line ('[':cs) = TokenOB : lexer line cs
lexer line (']':cs) = TokenCB : lexer line cs
lexer line ('!':('=':cs)) = TokenNEQ : lexer line cs
lexer line ('<':('=':cs)) = TokenLEQ : lexer line cs
lexer line ('<':cs) = TokenLT : lexer line cs
lexer line ('>':('=':cs)) = TokenGEQ : lexer line cs
lexer line ('>':cs) = TokenGT : lexer line cs
lexer line (':':('=':cs)) = TokenAssign : lexer line cs
lexer line ('-':('-':cs)) = lexLineComment line cs
lexer line ('/':('/':cs)) = lexComment line cs
lexer line ('-':cs) = TokenMinus : lexer line cs

lexNum line cs = TokenInt (read num) : lexer line rest
      where (num,rest) = span isDigit cs

lexIdent line cs =
   case span (\c -> (isAlphaNum c || c == '_')) cs of
      ("procedure",rest) -> TokenProcedure : lexer line rest
      ("function",rest)  -> TokenFunction : lexer line rest
      ("begin",rest)  -> TokenBegin : lexer line rest
      ("end",rest)  -> TokenEnd : lexer line rest
      ("while",rest)  -> TokenWhile : lexer line rest
      ("do",rest)  -> TokenDo : lexer line rest
      ("if",rest)  -> TokenIf : lexer line rest
      ("then",rest)  -> TokenThen : lexer line rest
      ("else",rest)  -> TokenElse : lexer line rest
      ("write",rest)  -> TokenWrite : lexer line rest
      ("read",rest)  -> TokenRead : lexer line rest
      ("return",rest)  -> TokenReturn : lexer line rest
      ("odd",rest)  -> TokenOdd : lexer line rest
      ("var",rest)  -> TokenVar : lexer line rest
      (var,rest)   -> TokenIdent var : lexer line rest

lexLineComment line ('\n':cs) = lexer (line + 1) cs
lexLineComment line (c:cs) = lexLineComment line cs

lexComment line ('*':('/':cs)) = lexer line cs
lexComment line (c:cs) = lexComment line cs

--main = getContents >>= print . parser . lexer 1
}