arrowrun004.hs 2.77 KB
Newer Older
1
{-# LANGUAGE Arrows, MultiParamTypeClasses, FlexibleInstances #-}
ross's avatar
ross committed
2
3
4
5
6
7
8

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

module Main(main) where

import Control.Arrow
9
import Control.Category
ross's avatar
ross committed
10
import Data.Char
11
import Prelude hiding (id, (.))
ross's avatar
ross committed
12
13
14
15
16
17
18
19
20
21
22
23

-- 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])])

24
25
26
27
28
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']

ross's avatar
ross committed
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
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
ross's avatar
ross committed
69
		(|(symbol Plus)|)
ross's avatar
ross committed
70
71
72
		y <- term -< ()
		expr' -< x + y
	<+> do
ross's avatar
ross committed
73
		(|(symbol Minus)|)
ross's avatar
ross committed
74
75
76
77
78
79
80
81
82
83
84
85
		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
ross's avatar
ross committed
86
		(|(symbol Mult)|)
ross's avatar
ross committed
87
88
89
		y <- factor -< ()
		term' -< x * y
	<+> do
ross's avatar
ross committed
90
		(|(symbol Div)|)
ross's avatar
ross committed
91
92
93
94
95
		y <- factor -< ()
		term' -< x `div` y

factor :: ExprParser () Int
factor = proc () -> do
ross's avatar
ross committed
96
		v <- (|(symbol Number)|)
ross's avatar
ross committed
97
98
		returnA -< read v::Int
	<+> do
ross's avatar
ross committed
99
		(|(symbol Minus)|)
ross's avatar
ross committed
100
101
102
		v <- factor -< ()
		returnA -< -v
	<+> do
ross's avatar
ross committed
103
		(|(symbol LPar)|)
ross's avatar
ross committed
104
		v <- expr -< ()
ross's avatar
ross committed
105
		(|(symbol RPar)|)
ross's avatar
ross committed
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
		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")