Parse2

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)

data ASTid = ID String
             deriving (Eq, Show)
data ASTint = NUM Int
              deriving (Eq, Show)
data ASTop = ADD | SUB | MUL | DIV              -- + | - | * | /
              deriving (Eq, Show)
data ASTcop = Eqt | Neqt | Gt | Geqt | Lt | Leqt    -- == | != | > | >= | < | <=
              deriving (Eq, Show)
data ASTexpr = E1 ASTid | E2 ASTint | E3 ASTop ASTexpr ASTexpr
               deriving (Eq, Show)
data ASTcomp = COMP1 ASTcop ASTexpr ASTexpr
             | COMP2 ASTexpr
               deriving (Eq, Show)
data ASTstat = SC ASTstat ASTstat
             | ASSIGN ASTid ASTexpr
             | IF ASTcomp ASTstat ASTstat
             | WHILE ASTcomp ASTstat
             | READ ASTid
             | WRITE ASTexpr
               deriving (Eq, Show)
data ASTprog = P ASTid ASTstat
               deriving (Eq, Show)


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 = case t of
            Eq   -> True
            Neq  -> True
            L    -> True
            Leq  -> True
            G    -> True
            Geq  -> True
            otherwise -> False

eop :: Token -> Bool
eop t = case t of
            Add  -> True
            Sub  -> True
            otherwise -> False

top :: Token -> Bool
top t = case t of
            Mul       -> True
            Div       -> True
            otherwise -> False

isId :: Token -> Bool
isId t = case t of
            Id str    -> True
            otherwise -> False

isNum :: Token -> Bool
isNum t = case t of
            Num num   -> True
            otherwise -> False

isSc :: Token -> Bool
isSc t = case t of
            Sc        -> True
            otherwise -> False

cEOP :: Token -> ASTop
cEOP t =    case t of
                Add  -> ADD
                Sub  -> SUB
                Mul  -> MUL
                Div  -> DIV

cCOP :: Token -> ASTcop
cCOP t =    case t of
                Eq  -> Eqt
                Neq -> Neqt
                L   -> Lt
                Leq -> Leqt
                G   -> Gt
                Geq -> Geqt



sequenceEXPR :: [Token] -> (ASTexpr, [Token])
sequenceEXPR s1 =   let
                        (x1, s2) = sequenceTERM s1
                        t:s3 = s2
                    in
                        if eop t then
                            let
                                (x2, sn) = sequenceTERM s3
                            in
                                (E3 (cEOP t) x1 x2, sn)
                        else
                            let
                                sn = s2
                            in
                                (x1, sn)

sequenceTERM :: [Token] -> (ASTexpr, [Token])
sequenceTERM s1 =   let
                        (x1, s2) = sequenceFACT s1
                        t:s3 = s2
                    in
                        if top t then
                            let
                                (x2, sn) = sequenceFACT s3
                            in
                                (E3 (cEOP t) x1 x2, sn)
                        else
                            let
                                sn = s2
                            in
                                (x1, sn)


sequenceCOMP :: [Token] -> (ASTcomp, [Token])
sequenceCOMP s1 =   let
                        (x1, s2) = sequenceEXPR s1
                        t:s3 = s2
                    in
                        if cop t then
                            let
                                (x2, sn) = sequenceEXPR s3
                            in
                                (COMP1 (cCOP t) x1 x2, sn)
                        else
                            let
                                sn = s2
                            in
                                ((COMP2 x1), sn)


sequenceFACT :: [Token] -> (ASTexpr, [Token])
sequenceFACT s1 =   let
                        t:s2 = s1
                    in
                        if isId t then
                            let
                                sn = s2
                            in
                                ((E1 (ID (idT t))), sn)
                        else if isNum t then
                            let
                                sn = s2
                            in
                                ((E2 (NUM (numT t))), sn)
                        else
                            let
                                Lp:s2 = s1
                                (e, s3) = sequenceEXPR s2
                                Rp:sn = s3
                            in
                                (e, sn)

sequenceSTAT :: [Token] -> (ASTstat, [Token])
sequenceSTAT s1 =   let
                        (x1, s2) = stat s1
                        t:s3 = s2
                    in
                        if isSc t then
                            let
                                (x2, sn) = sequenceSTAT s3
                            in
                                ((SC x1 x2), sn)
                        else
                            let
                                sn = s2
                            in
                                (x1, sn)

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

stat :: [Token] -> (ASTstat, [Token])
stat s1 = let
            t:s2 = s1
          in
            case t of
            Begin ->
                -- Begin
                let
                    (x1, sn) = sequenceSTAT s2
                in
                    (x1, [End]++sn)
            If ->
                -- If
                let
                    (c, s3) = sequenceCOMP s2
                    Then:s4 = s3
                    (x1, s5) = stat s4
                    Else:s6 = s5
                    (x2, sn) = stat s6
                in
                    ((IF c x1 x2), sn)
            While ->
                -- While
                let
                    (c, s3) = sequenceCOMP s2
                    Do:s4 = s3
                    (x, sn) = stat s4
                in
                    ((WHILE c x), sn)
            Read ->
                -- Read
                let
                    (i, sn) = idTk s2
                in
                    ((READ i), sn)
            Write ->
                -- Write
                let
                    (e, sn) = sequenceEXPR s2
                in
                    ((WRITE e), sn)
            Id str ->
                -- Assign
                let
                    Att:s3 = s2
                    (e, sn) = sequenceEXPR s3
                in
                    ((ASSIGN (ID str) e), sn)
            otherwise ->
                error "Ill Formed Program"

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

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]