Ticket #7372: applicative-eval.hs

File applicative-eval.hs, 1.6 KB (added by simonpj, 3 years ago)

Offending program

Line 
1module Main where
2
3import Control.Applicative (pure,(<*>),(<$>),(<$),(<*),(*>))
4import Text.Parsec
5import System.IO (stdout,hSetBuffering,BufferMode(NoBuffering))
6
7data Exp = Cte Integer
8         | Var String
9         | Sum Exp Exp
10         | Sub Exp Exp
11         | Mul Exp Exp
12         | Div Exp Exp
13         | Let String Exp Exp
14         deriving (Show)
15
16type Memory = [(String,Integer)]
17
18eval :: Exp -> (->) Memory Integer
19eval (Cte i) = pure i
20eval (Var s) = \m -> case lookup s m of
21                       Just v -> v
22                       Nothing -> 0
23eval (Sum a b) = (+) <$> eval a <*> eval b
24eval (Sub a b) = (-) <$> eval a <*> eval b
25eval (Mul a b) = (*) <$> eval a <*> eval b
26eval (Div a b) = (div) <$> eval a <*> eval b
27eval (Let s a b) = \m -> eval b ((s,eval a m):m)
28
29pExp, pTerm, pFactor :: Parsec String () Exp
30pExp = chainl1 pTerm (lexeme (Sum <$ char '+' <|> Sub <$ char '-'))
31pTerm = chainl1 pFactor (lexeme (Mul <$ char '*' <|> Div <$ char '/'))
32pFactor = Cte <$> lexeme pInteger <|>
33          Var <$> lexeme pVariable <|>
34          lexeme (char '(') *> pExp <* lexeme (char ')')
35pInteger = read <$> many1 digit
36pVariable = (:) <$> letter <*> many (alphaNum <|> char '-')
37
38lexeme p = p <* spaces
39
40
41
42main = do hSetBuffering stdout NoBuffering
43          calc 1
44
45calc n = do putStr ("[" ++ show n ++ "] ")
46            input <- getLine
47            case parse pExp "-" input of
48              Left err -> putStrLn (show err)
49              Right exp -> do putStrLn (show exp)
50                              putStrLn (show (eval exp []))
51            calc (n+1)