{-# OPTIONS -fglasgow-exts #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  ParseExp
-- Copyright   :  (C) 2007 Ulisses Araujo Costa
--
-- Maintainer  :  ulissesmonhecosta@gmail.com
-- Portability :  portable
--
-- A very simple expression parser...
--
-----------------------------------------------------------------------------
module ParseExp where

import Char

data Ops = Add | Mul | Sim | Sub | Div
        | OR_ | AND_ | NOT_ | GE_
        | GT_ | LE_ | LT_ | EQ_ | NE_
        deriving Eq

data Exp o = Const Int | Var String | Op o [Exp o]

class Opt o where
        arity :: o -> Int

instance Opt Ops where
        arity Add = 2 ; arity Mul = 2 ; arity Sim = 1 ; arity Sub = 2
        arity Div = 2 ; arity OR_ = 2 ; arity AND_ = 2 ; arity NOT_ = 1
        arity GE_ = 2 ; arity GT_ = 2 ; arity LE_ = 2 ; arity LT_ = 2
        arity EQ_ = 2 ; arity NE_ = 2

instance Show Ops where
        show Add = "+" ; show Mul = "*" ; show Sim = "~" ; show Sub = "-"
        show Div = "/" ; show OR_ = "||" ; show AND_ = "&&" ; show NOT_ = "!"
        show GE_ = ">=" ; show GT_ = ">" ; show LE_ = "<=" ; show LT_ = "<"
        show EQ_ = "==" ; show NE_ = "!="

instance (Show o,Opt o) => Show (Exp o) where
    show (Const n) = show n
    show (Var s) = s
    show (Op o l)
        | arity o == 2 = "(" ++ (show $ head l) ++ show o ++ (show $ last l) ++ ")"
        | arity o == 1 = "(" ++ show o ++ (show $ head l) ++ ")"

readsExp :: ReadS (Exp Ops)
readsExp s =
    [((leOp "~" [a]),p4) | ("(",p1) <- lex s,
        ("~",p2) <- lex p1,
        (a,p3)   <- readsExp p2,
        (")",p4) <- lex p3] ++
    [((leOp op [a,b]),p5) | ("(",p1) <- lex s,
        (a,p2)  <- readsExp p1,
        (op,p3) <- lex p2,
        op == "+" || op == "*" || op == "/" ||
        op == "-" || op == "||" || op == "&&" ||
        op == "==" || op == "!=" || op == ">=" ||
        op == "<=" || op == "!" || op == ">" ||
        op == "<",
        (b,p4) <- readsExp p3,
        (")",p5) <- lex p4 ] ++
    [((Const ((read a)::Int)),sx) | (a,sx) <- lex s, all isDigit a] ++
    [((Var a),sx) | (a,sx) <- lex s, all isAlpha a]
    where
        leOp :: String -> [Exp Ops] -> Exp Ops
        leOp o = Op (read o::Ops)

instance Read Ops where
        readsPrec _ "+" = [(Add,"")] ; readsPrec _ "*" = [(Mul,"")] ; readsPrec _ "~" = [(Sim,"")]
        readsPrec _ "-" = [(Sub,"")] ; readsPrec _ "/" = [(Div,"")] ; readsPrec _ "||" = [(OR_,"")]
        readsPrec _ "&&" = [(AND_,"")] ; readsPrec _ "!" = [(NOT_,"")] ; readsPrec _ ">=" = [(GE_,"")]
        readsPrec _ ">" = [(GT_,"")] ; readsPrec _ "<=" = [(LE_,"")] ; readsPrec _ "<" = [(LT_,"")]
        readsPrec _ "==" = [(EQ_,"")] ; readsPrec _ "!=" = [(NE_,"")]

instance Read (Exp Ops) where
        readsPrec _ s = readsExp s

parsing :: String -> Exp Ops
parsing = read

-- tests
--
-- example usages:
--  parsing "((~2)+xpto)"
--  parsing "(((~2)+(34*x))/67)"
--