{-# 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")