Parse

data Token = Program
            | Id String
            | Sc                -- semicolon
            | End
            | If
            | Then
            | Else
            | While
            | Do
            | Read
            | Write
            | Num Int
            | Eq                -- COP Latex-Like...
            | Neq               -- not equal
            | G                 -- greater than
            | Geq               -- greater or equal than
            | L                 -- less than
            | Leq               -- less or equal than
            | Add               -- +
            | Sub               -- -
            | Mul               -- *
            | Div               -- /
            | Lp                -- (
            | Rp                -- )
            | Begin
            | Att               -- :=
            | Assign
            deriving (Eq, Show)

enum :: Token -> Int
enum t =
    case t of
        Program -> 1
        Id st   -> 2
        Sc      -> 3
        End     -> 4
        If      -> 5
        Then    -> 6
        Else    -> 7
        While   -> 8
        Do      -> 9
        Read    -> 10
        Write   -> 11
        Num num -> 12
        Eq      -> 13
        Neq     -> 14
        G       -> 15
        Geq     -> 16
        L       -> 17
        Leq     -> 18
        Add     -> 19
        Sub     -> 20
        Mul     -> 21
        Div     -> 22
        Lp      -> 23
        Rp      -> 24
        Begin   -> 25
        Att     -> 26
        Assign  -> 27

data ASTid = ID String
data ASTint = NUM Int
data ASTatt = ATT                               -- :=
data ASTp = LP | RP                             -- ( | )
data ASTop = ADD | SUB | MUL | DIV              -- + | - | * | /
data ASTcop = EQ | NEQ | GT | GEQ | LT | LEQ    -- == | != | > | >= | < | <=
data ASTexpr = ASTid | ASTint | ASTop ASTp ASTexpr ASTexpr ASTp
data ASTcomp = ASTcop ASTp ASTexpr ASTexpr ASTp
data ASTstat = SC ASTp ASTstat ASTstat
             | ASSIGN ASTp ASTid ASTexpr ASTp
             | IF ASTp ASTcomp ASTstat ASTstat ASTp
             | WHILE ASTp ASTcomp ASTstat ASTp
             | READ ASTp ASTid ASTp
             | WRITE ASTp ASTexpr ASTp
data ASTprog = P ASTid ASTstat


idT :: Token -> String
idT t =
    case t of
        Id str -> str

numT :: Token -> Int
numT t =
    case t of
        Num num -> num

cop :: Token -> Bool
cop t = let
            typenum = enum t
        in
            typenum >= 13 && typenum <= 18

eop :: Token -> Bool
eop t = let
            typenum = enum t
        in
            typenum == 19 || typenum == 20

top :: Token -> Bool
top t = let
            typenum = enum t
        in
            typenum == 21 || typenum == 22

isId :: Token -> Bool
isId t = let
                typenum = enum t
            in
                typenum == 2


isNum :: Token -> Bool
isNum t =   let
                typenum = enum t
            in
                typenum == 12

isSc :: Token -> Bool
isSc t = let
            typenum = enum t
         in
            typenum == 3

sequenceT :: ([Token] -> ([Token], [Token])) -> (Token -> Bool) -> [Token] -> ([Token], [Token])
sequenceT nonTerm sep s1 =  let
                                (x1, s2) = nonTerm s1
                                t:s3 = s2
                            in
                                if sep t then
                                    let
                                        (x2, sn) = sequenceT nonTerm sep s3
                                    in
                                        ([t, Lp]++x1++x2++[Rp], sn)
                                else
                                    let
                                        sn = s2
                                    in
                                        (x1, sn)

fact :: [Token] -> ([Token], [Token])
fact s1 =   let
                t:s2 = s1
            in
                if isNum t || isId t then
                    let
                        sn = s2
                    in
                        ([t], sn)
                else
                    let
                        Lp:s2 = s1
                        (e, s3) = expr s2
                        Rp:sn = s3
                    in
                        (e, sn)


term :: [Token] -> ([Token], [Token])
term s1 =   let
                (x1, sn) = sequenceT fact top s1
            in
                (x1, sn)

expr :: [Token] -> ([Token], [Token])
expr s1 =   let
                (x1, sn) = sequenceT term eop s1
            in
                (x1, sn)

comp :: [Token] -> ([Token], [Token])
comp s1 =   let
                (x1, sn) = sequenceT expr cop s1
            in
                (x1, sn)


idTk :: [Token] -> ([Token], [Token])
idTk s1 = let
            x:sn = s1
        in
            if isId x then
                ([x], sn)
            else
                error "Ill Formed Program"

stat :: [Token] -> ([Token], [Token])
stat s1 = let
            t:s2 = s1
            typenum = enum t
          in
            if typenum == 25 then
                -- Begin
                let
                    (x1, sn) = sequenceT stat isSc s2
                in
                    (x1, [End]++sn)
            else if typenum == 5 then
                -- If
                let
                    (c, s3) = comp s2
                    Then:s4 = s3
                    (x1, s5) = stat s4
                    Else:s6 = s5
                    (x2, sn) = stat s6
                in
                    ([If, Lp]++c++x1++x2++[Rp], sn)
            else if typenum == 8 then
                -- While
                let
                    (c, s3) = comp s2
                    Do:s4 = s3
                    (x, sn) = stat s4
                in
                    ([While, Lp]++c++x++[Rp], sn)
            else if typenum == 10 then
                -- Read
                let
                    (i, sn) = idTk s2
                in
                    ([Read, Lp]++i++[Rp], sn)
            else if typenum == 11 then
                -- Write
                let
                    (e, sn) = expr s2
                in
                    ([Write, Lp]++e++[Rp], sn)
            else if isId t then
                -- Assign
                let
                    Att:s3 = s2
                    (e, sn) = expr s3
                in
                    ([Assign, Lp, t]++e++[Rp], sn)
            else
                error "Ill Formed Program"

prog :: [Token] -> ([Token], [Token])
prog s1 =   let
                Program:s2 = s1
                (y, s3) = idTk s2
                Sc:s4 = s3
                (z, s5) = stat s4
                End:sn = s5
            in
                ([Program, Lp]++y++z++[Rp], sn)

tokenToString :: Token -> String
tokenToString t =
    case t of
        Program -> "prog"
        Id st   -> st
        Sc      -> ";"
        End     -> "end"
        If      -> "if"
        Then    -> "then"
        Else    -> "else"
        While   -> "while"
        Do      -> "do"
        Read    -> "read"
        Write   -> "write"
        Num num -> show num
        Eq      -> "=="
        Neq     -> "!="
        G       -> ">"
        Geq     -> ">="
        L       -> "<"
        Leq     -> "<="
        Add     -> "+"
        Sub     -> "-"
        Mul     -> "*"
        Div     -> "/"
        Lp      -> "("
        Rp      -> ")"
        Begin   -> "begin"
        Att     -> ":="
        Assign  -> "assign"

convert :: [Token] -> String
convert l = if l /= [] then
                let
                    x:xs = l
                in
                    tokenToString x ++ " " ++ convert xs
            else
                []


a = [Program, Id "foo", Sc, While, Id "a", Add, Num 3, L, Id "b", Do, Id "b", Att, Id "b", Add, Num 1, End]
b = [Program, Id "foo", Sc, Begin, While, Id "a", Add, Num 3, L, Id "b", Do, Id "b", Att, Id "b", Add, Num 1, Sc, While, Id "a", Add, Num 3, L, Id "b", Do, Id "b", Att, Id "b", Add, Num 1, End, End]
c = [Program, Id "foo", Sc, Id "a", Att, Num 5, Add, Num 5, End]
d = [Program, Id "foo", Sc, Read, Id "a", End]
e = [Program, Id "foo", Sc, Write, Num 5, Add, Num 5, End]
f = [Program, Id "foo", Sc, If, Id "a", Then, Id "b", Att, Num 5, Else, Id "b", Att, Num 123, End]