Parser

module Parser where

import Data.Char
import Data.Maybe
import Control.Exception

import ParserM hiding (Parser)
import qualified ParserM as P
import AST

import State(Error)
type Parser  = P.Parser Char

--
-- Part I: Expressions.
--

-- Variable ::= Char (Char|Digit)^*
identifier :: Parser String
identifier = do c<- satisfy isLetter;
                cs<- many $ satisfy isAlphaNum
                return $ c:cs

-- Number ::= Digit+ ('.' Digit+)?
digitseq = many1 $ satisfy isDigit
number :: Parser Double
number = do
  ds<- digitseq;
  ds2 <- opt (do {t<- token '.'; ds<- digitseq; return $ t:ds })
  return $ read $ ds ++ fromMaybe "" ds2

-- Factor ::= Identifier | Number | '(' Expr ')' | '-' Expr
factor :: Parser Expr
factor = fmap Var identifier +++ fmap Number number
        +++ do { token '-'; e<- expr; return $ Negate e }
        +++ brackets '(' expr ')'

-- Term ::= Factor '*' Term  | Factor '/' Term | Factor
term :: Parser Expr
term =
  do { e1<- factor; token '*'; e2 <- term; return $ Times e1 e2 }
  +++
  do { e1<- factor; token '/'; e2 <- term; return $ Div e1 e2 }
  +++ factor

-- ATerm ::= Term '+' ATerm | Term
aterm :: Parser Expr
aterm = do { e1<- term; token '+'; e2 <- aterm; return $ Plus e1 e2 }
  +++ term

-- Expr ::= ATerm '<=' ATerm | ATerm '=' ATerm | ATerm
expr :: Parser Expr
expr =
  do { e1<- aterm; tokens "<="; e2 <- aterm; return $ LessEq e1 e2 }
  +++
  do { e1<- aterm; token '='; e2 <- aterm; return $ Eq e1 e2 }
  +++
  do {token '<'; e1<- aterm; token ','; e2 <- aterm; token '>'; return $ Pair e1 e2 }
  +++ aterm



--
-- Part II: Commands
--

-- cmd ::=
cmd :: Parser Cmd
cmd = choice [printStmt, whileStmt, ifStmt, assignStmt, moveStmt, lineStmt, curveStmt, circleStmt, arcStmt, colourStmt]

--         'print' expr
printStmt :: Parser Cmd
printStmt = do
                tokens "print"
                e<- expr
                return $ Print e

--         'move' expr
moveStmt :: Parser Cmd
moveStmt = do
                tokens "move"
                e<- expr
                return $ Draw (Move e)

--         'line' expr
lineStmt :: Parser Cmd
lineStmt = do
                tokens "line"
                e<- expr
                return $ Draw (Line e)

--         'curve' expr expr expr
curveStmt :: Parser Cmd
curveStmt = do
                tokens "curve"
                token '('
                e1<- expr
                token ','
                e2<- expr
                token ','
                e3<- expr
                token ')'
                return $ Draw (Curve e1 e2 e3)

--         'circle' expr
circleStmt :: Parser Cmd
circleStmt = do
                tokens "circle"
                e<- expr
                return $ Draw (Circle e)

--         'arc' expr
arcStmt :: Parser Cmd
arcStmt = do
                tokens "arc"
                token '('
                e1<- expr
                token ','
                e2<- expr
                token ','
                e3<- expr
                token ')'
                return $ Draw (Arc e1 e2 e3)

--         'colour' identifier
colourStmt :: Parser Cmd
colourStmt = do
                tokens "colour"
                id<- identifier
                return $ Draw (Color id)

--       | 'while' expr brcmdseq
whileStmt :: Parser Cmd
whileStmt = do
  tokens "while"; e<- expr; cs <- brCmdSeq;
  return $ While e cs

--       | 'if' expr brcmdSeq ['else' brcmdseq]
ifStmt :: Parser Cmd
ifStmt = do
  tokens "if"; e<- expr; cs <- brCmdSeq
  ds <- opt (do { tokens "else"; brCmdSeq })
  return $ If e cs (fromMaybe [] ds)

--       | identifier ':=' expr
assignStmt :: Parser Cmd
assignStmt =
   do { id <- identifier; tokens ":="; e<- expr; return $ Assign id e }

--  brcmdseq ::= '{' cmds '}'
--  cmds     ::= cmd ';' cmds | cmd
brCmdSeq :: Parser [Cmd]
brCmdSeq = brackets '{' (sepby1 cmd ';') '}'


program :: Parser Prog
program =
  do
    tokens "tsvg"
    id    <- identifier
    num   <- opt (do
                    token '('
                    x<- number
                    token ','
                    y<- number
                    token ')'
                    return (x,y))
    token ';'
    decls <- many (do
                     tokens "var"
                     id<- identifier
                     token ';'
                     return id)
    cmds  <- sepby cmd ';'
    return $ Tsvg id (fromMaybe (1000, 1000) num) decls cmds
  +++
  do
    decls <- many (do
                     tokens "var"
                     id<- identifier
                     token ';'
                     return id)
    cmds  <- sepby cmd ';'
    return $ Prog decls cmds


--
-- Part III: Main function
--
parseMain :: String -> Error Prog
parseMain inp = case parse program (filter (not.isSpace) inp) of
    [(st, [])] -> Right st
    [(st, r)]  -> Left $ "Parse error on input '" ++ [head r]
        ++ "' (" ++ show (length inp - length r) ++ ")"++ "Rest: "++ tail r
    _ -> Left $ "Parse error (no parse)"

parseFromFile :: String-> IO (Error Prog)
parseFromFile filenm =
  catch (do cont<- readFile filenm
            return $ parseMain cont)
        (\e-> return $ Left $ "I/O error: "++ show (e :: IOError))