c0275065f2365b4bb6b53d6558450183ba920829
[ghc.git] / testsuite / tests / arrows / should_run / arrowrun004.hs
1 {-# LANGUAGE Arrows, MultiParamTypeClasses, FlexibleInstances #-}
2
3 -- Simple expression parser
4 -- (uses do-notation and operators)
5
6 module Main(main) where
7
8 import Control.Arrow
9 import Control.Category
10 import Data.Char
11 import Prelude hiding (id, (.))
12
13 -- Parsers
14
15 class (Eq s, Show s, ArrowPlus a) => ArrowParser s a where
16 symbol :: s -> a b String
17
18 data Sym s = Sym { token :: s, value :: String }
19
20 -- Simple backtracking instance
21
22 newtype BTParser s a b = BTParser (a -> [Sym s] -> [(b, [Sym s])])
23
24 instance Category (BTParser s) where
25 id = BTParser $ \a ss -> [(a, ss)]
26 BTParser f . BTParser g = BTParser $ \b ss ->
27 [(d, ss'') | (c, ss') <- g b ss, (d, ss'') <- f c ss']
28
29 instance Arrow (BTParser s) where
30 arr f = BTParser $ \a ss -> [(f a, ss)]
31 first (BTParser f) = BTParser $ \(b,d) ss ->
32 [((c,d), ss') | (c,ss') <- f b ss]
33
34 instance ArrowZero (BTParser s) where
35 zeroArrow = BTParser $ \b ss -> []
36
37 instance ArrowPlus (BTParser s) where
38 BTParser f <+> BTParser g = BTParser $ \b ss -> f b ss ++ g b ss
39
40 instance (Eq s, Show s) => ArrowParser s (BTParser s) where
41 symbol s = BTParser $ \b ss ->
42 case ss of
43 Sym s' v:ss' | s' == s -> [(v, ss')]
44 _ -> []
45
46 runBTParser :: BTParser s () c -> [Sym s] -> c
47 runBTParser (BTParser parser) syms =
48 head [c | (c, []) <- parser () syms]
49
50 -- Expressions
51
52 data ESym = LPar | RPar | Plus | Minus | Mult | Div | Number | Unknown
53 deriving (Show, Eq, Ord)
54
55 type ExprParser = BTParser ESym
56 type ExprSym = Sym ESym
57
58 -- The grammar
59
60 expr :: ExprParser () Int
61 expr = proc () -> do
62 x <- term -< ()
63 expr' -< x
64
65 expr' :: ExprParser Int Int
66 expr' = proc x -> do
67 returnA -< x
68 <+> do
69 (|(symbol Plus)|)
70 y <- term -< ()
71 expr' -< x + y
72 <+> do
73 (|(symbol Minus)|)
74 y <- term -< ()
75 expr' -< x - y
76
77 term :: ExprParser () Int
78 term = proc () -> do
79 x <- factor -< ()
80 term' -< x
81
82 term' :: ExprParser Int Int
83 term' = proc x -> do
84 returnA -< x
85 <+> do
86 (|(symbol Mult)|)
87 y <- factor -< ()
88 term' -< x * y
89 <+> do
90 (|(symbol Div)|)
91 y <- factor -< ()
92 term' -< x `div` y
93
94 factor :: ExprParser () Int
95 factor = proc () -> do
96 v <- (|(symbol Number)|)
97 returnA -< read v::Int
98 <+> do
99 (|(symbol Minus)|)
100 v <- factor -< ()
101 returnA -< -v
102 <+> do
103 (|(symbol LPar)|)
104 v <- expr -< ()
105 (|(symbol RPar)|)
106 returnA -< v
107
108 -- Lexical analysis
109
110 lexer :: String -> [ExprSym]
111 lexer [] = []
112 lexer ('(':cs) = Sym LPar "(":lexer cs
113 lexer (')':cs) = Sym RPar ")":lexer cs
114 lexer ('+':cs) = Sym Plus "+":lexer cs
115 lexer ('-':cs) = Sym Minus "-":lexer cs
116 lexer ('*':cs) = Sym Mult "*":lexer cs
117 lexer ('/':cs) = Sym Div "/":lexer cs
118 lexer (c:cs)
119 | isSpace c = lexer cs
120 | isDigit c = Sym Number (c:w):lexer cs'
121 | otherwise = Sym Unknown [c]:lexer cs
122 where (w,cs') = span isDigit cs
123
124 parse = runBTParser expr . lexer
125
126 main = do
127 print (parse "1+2*(3+4)")
128 print (parse "3*5-17/3+4")