Commit 35e989f1 authored by ross's avatar ross
Browse files

[project @ 2003-06-24 09:45:23 by ross]

another arrows test
parent 09d7b733
......@@ -12,6 +12,7 @@ test('arrowrec1', normal, compile, [''])
test('arrowex1', normal, compile_and_run, [''])
test('arrowex2', normal, compile_and_run, [''])
test('arrowex3', normal, compile_and_run, [''])
test('arrowex4', normal, compile_and_run, [''])
# test('mod1', normal, compile_fail, [''])
# test('mod2', normal, compile_fail, [''])
......
{-# OPTIONS -farrows -fglasgow-exts #-}
-- Simple expression parser
-- (uses do-notation and operators)
module Main(main) where
import Control.Arrow
import Data.Char
-- 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 Arrow (BTParser s) where
arr f = BTParser $ \a ss -> [(f a, ss)]
BTParser f >>> BTParser g = BTParser $ \b ss ->
[(d, ss'') | (c, ss') <- f b ss, (d,ss'') <- g c 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")
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment