fork download 
  1. import Control.Applicative
  2. import Control.Monad
  3. import Data.Tree
  4.  
  5. data Parser a = P(String -> [(a,String)])
  6.  
  7. headOption (x:xs) = Just x
  8. headOption [] = Nothing
  9.  
  10. parse (P m) = m
  11.  
  12. result m s= case headOption (parse m s) of
  13. 	Just(res,"") -> Just(res)
  14. 	_ -> Nothing
  15. instance Functor Parser where
  16. 	fmap f m = m >>= \a -> return $ f a
  17.  
  18. instance Monad Parser where
  19. 	return a = P (\s -> [(a,s)])
  20. 	(>>=) (P m) f = P(\s -> m s >>= \(a,s) -> parse (f a) s)
  21.  
  22. instance MonadPlus Parser where
  23. 	mzero = P(\s -> [])
  24. 	mplus (P a) (P b) = P(\s -> (a s) ++ (b s)) 
  25.  
  26. instance Applicative Parser where
  27. 	pure = return
  28. 	(<*>) mf ma = mf >>= \f -> ma >>= \a -> return $ f a
  29.  
  30. instance Alternative Parser where
  31. 	empty = mzero
  32. 	(<|>) = mplus
  33.  
  34. zero' _ _ = []
  35. zero a = P(zero' a)
  36.  
  37. item' (x:xs) = [(x,xs)]
  38. item' [] = []
  39. item = P(item')
  40.  
  41. term y = P(term' y)
  42. term' y (x:xs) = if(x == y) then [(y,xs)] else [] 
  43. term' y [] = []
  44.  
  45. word = sequence . map (term) 
  46. digits = some $ msum $ map term ['0'..'9']
  47. integerParser = fmap (read :: String -> Integer) digits
  48. floatParser = fmap (read :: String -> Float) $ fmap join $ sequence [digits,fmap (join) (sequence [word ".",digits]) <|> (return "")]
  49. oper op s = fmap (const $ BinaryOp op) $ word s
  50. unary op s = fmap (const $ UnaryOp op) $ word s
  51.  
  52. data Token = Val Float | BinaryOp (Float -> Float -> Float) | UnaryOp (Float -> Float)
  53. type AST = Tree Token
  54.  
  55. node x = Node x []
  56. unaryMin x = -x
  57. unfolder (term1,((op,term2):xs)) = (node op,[(term1,[]),(term2,xs)])
  58. unfolder (term1,[]) = (term1,[])
  59. tokenToString (Val x) = show x
  60. tokenToString _ = "op"
  61. spaces = many $ word " "
  62.  
  63. between p m = do {p; r <- m; p; return r }
  64.  
  65. termAndOperations terms ops = do
  66. 	spaces
  67. 	term <- terms
  68. 	op <- ops
  69. 	spaces
  70. 	return $ join $ unfoldTree unfolder (term,op)
  71.  
  72. expr = let unaryAndFactors = do { op <- unary unaryMin "-"; term <- eterm; return $ Node op [term] } <|> eterm;
  73. 		   additionAndSubstruction = many $ do { op <- oper (+) "+" <|> oper (-) "-"; other <- eterm; return (op,other) } 
  74. 		in termAndOperations unaryAndFactors additionAndSubstruction
  75. eterm = let exponent = expterm;
  76. 			multAndDiv = many $ do { op <- oper (*) "*" <|> oper (/) "/"; f <- expterm; return (op,f)  }
  77. 		in termAndOperations exponent multAndDiv 
  78. expterm = let exponentOp = many $ do {op <- oper (**) "^"; f <- factor; return (op,f)}
  79. 		  in termAndOperations factor exponentOp
  80. factor = between spaces $ (fmap (node . Val) floatParser) <|> do { word "("; e <- expr;word ")"; return e; }
  81.  
  82.  
  83. compute (Node (BinaryOp(f)) (x:y:[])) = compute(x) `f` compute(y)
  84. compute (Node (UnaryOp(f)) (x:[])) = f $ compute(x)
  85. compute (Node (Val(x)) []) = x
  86.  
  87. eval = fmap compute . result expr
  88.  
  89. data InterpeterTestCases a = EqualityOf String (Maybe a)
  90.  
  91. tests :: [InterpeterTestCases Float]
  92. tests = [
  93. 	EqualityOf "2 + 3" $ Just(5),
  94. 	EqualityOf "4 - 3" $ Just(1),
  95. 	EqualityOf "2 + (-3)" $ Just(-1),
  96. 	EqualityOf "4 * 5" $ Just(20),
  97. 	EqualityOf "6/4" $ Just(6/4),
  98. 	EqualityOf "1.2 + 1/2" $ Just(1.2+1/2),
  99. 	EqualityOf "1/(-3)" $ Just(1/(-3)),
  100. 	EqualityOf "0.5 + 0.2" $ Just(0.7),
  101. 	EqualityOf "3 ^ 2 ^ 2" $ Just(81),
  102. 	EqualityOf "17654/342" $ Just(8827/171),
  103. 	EqualityOf "2/3^2" $ Just(2/9),
  104. 	EqualityOf "(2/3)^2" $ Just(4/9)] 
  105.  
  106. main = do
  107. 	print "(2 + 3) / (2 - 2) == Just(Infinity)"
  108. 	print $ Just $ Just(1/0) == eval "(2 + 3) / (2 - 2)"
  109. 	print "2 + 345 + + + + 6 == Nothing"
  110. 	print $ Just $ Nothing == eval "2 + 345 + + + + 6"  
  111. 	forM_ tests $ \(EqualityOf expr expected) -> do 
  112. 		print $ expr ++ " == " ++ (show expected)
  113. 		let difference = liftA2 (-) (eval expr) expected
  114. 		print $ fmap ((<0.0001) . abs) difference
Success #stdin #stdout 0s 6360KB
comments (?)
stdin 
Standard input is empty
stdout 
"(2 + 3) / (2 - 2) == Just(Infinity)"
Just True
"2 + 345 + + + + 6 == Nothing"
Just True
"2 + 3 == Just 5.0"
Just True
"4 - 3 == Just 1.0"
Just True
"2 + (-3) == Just (-1.0)"
Just True
"4 * 5 == Just 20.0"
Just True
"6/4 == Just 1.5"
Just True
"1.2 + 1/2 == Just 1.7"
Just True
"1/(-3) == Just (-0.33333334)"
Just True
"0.5 + 0.2 == Just 0.7"
Just True
"3 ^ 2 ^ 2 == Just 81.0"
Just True
"17654/342 == Just 51.619884"
Just True
"2/3^2 == Just 0.22222222"
Just True
"(2/3)^2 == Just 0.44444445"
Just True
https://ideone.com/3iwkxg
Привет /pr/!
language:
Haskell (ghc 8.4.4)
created:
11 years ago
visibility:
secret

Share or Embed source code

Discover > Sphere Engine API

The brand new service which powers Ideone!

Discover > IDE Widget

Widget for compiling and running the source code in a web browser!