{-# LANGUAGE Arrows, MultiParamTypeClasses, FlexibleInstances #-}

-- Simple expression parser
-- (uses do-notation and operators)

module Main(main) where

import Control.Arrow
import Control.Category
import Data.Char
import Prelude hiding (id, (.))

-- Parsers

class (Eq s, Show s, ArrowPlus a) => ArrowParser s a where
        symbol :: s -> a b String

data Sym s = Sym { token :: s, value :: String }

-- Simple backtracking instance

newtype BTParser s a b = BTParser (a -> [Sym s] -> [(b, [Sym s])])

instance Category (BTParser s) where
        id = BTParser $ \a ss -> [(a, ss)]
        BTParser f . BTParser g = BTParser $ \b ss ->
                [(d, ss'') | (c, ss') <- g b ss, (d, ss'') <- f c ss']

instance Arrow (BTParser s) where
        arr f = BTParser $ \a ss -> [(f a, ss)]
        first (BTParser f) = BTParser $ \(b,d) ss ->
                [((c,d), ss') | (c,ss') <- f b ss]

instance ArrowZero (BTParser s) where
        zeroArrow = BTParser $ \b ss -> []

instance ArrowPlus (BTParser s) where
        BTParser f <+> BTParser g = BTParser $ \b ss -> f b ss ++ g b ss

instance (Eq s, Show s) => ArrowParser s (BTParser s) where
        symbol s = BTParser $ \b ss ->
                case ss of
                Sym s' v:ss' | s' == s -> [(v, ss')]
                _ -> []

runBTParser :: BTParser s () c -> [Sym s] -> c
runBTParser (BTParser parser) syms =
        head [c | (c, []) <- parser () syms]

-- Expressions

data ESym = LPar | RPar | Plus | Minus | Mult | Div | Number | Unknown
        deriving (Show, Eq, Ord)

type ExprParser = BTParser ESym
type ExprSym = Sym ESym

-- The grammar

expr :: ExprParser () Int
expr = proc () -> do
                x <- term -< ()
                expr' -< x

expr' :: ExprParser Int Int
expr' = proc x -> do
                returnA -< x
        <+> do
                (|(symbol Plus)|)
                y <- term -< ()
                expr' -< x + y
        <+> do
                (|(symbol Minus)|)
                y <- term -< ()
                expr' -< x - y

term :: ExprParser () Int
term = proc () -> do
                x <- factor -< ()
                term' -< x

term' :: ExprParser Int Int
term' = proc x -> do
                returnA -< x
        <+> do
                (|(symbol Mult)|)
                y <- factor -< ()
                term' -< x * y
        <+> do
                (|(symbol Div)|)
                y <- factor -< ()
                term' -< x `div` y

factor :: ExprParser () Int
factor = proc () -> do
                v <- (|(symbol Number)|)
                returnA -< read v::Int
        <+> do
                (|(symbol Minus)|)
                v <- factor -< ()
                returnA -< -v
        <+> do
                (|(symbol LPar)|)
                v <- expr -< ()
                (|(symbol RPar)|)
                returnA -< v

-- Lexical analysis

lexer :: String -> [ExprSym]
lexer [] = []
lexer ('(':cs) = Sym LPar "(":lexer cs
lexer (')':cs) = Sym RPar ")":lexer cs
lexer ('+':cs) = Sym Plus "+":lexer cs
lexer ('-':cs) = Sym Minus "-":lexer cs
lexer ('*':cs) = Sym Mult "*":lexer cs
lexer ('/':cs) = Sym Div "/":lexer cs
lexer (c:cs)
        | isSpace c = lexer cs
        | isDigit c = Sym Number (c:w):lexer cs'
        | otherwise = Sym Unknown [c]:lexer cs
                where (w,cs') = span isDigit cs

parse = runBTParser expr . lexer

main = do
        print (parse "1+2*(3+4)")
        print (parse "3*5-17/3+4")
