SHARE
TWEET

VoidEx

a guest Nov 5th, 2007 45 Never
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
  1. data PMaybe a = PJust a | PError String
  2. data Parsed a = Parsed (String -> (String, PMaybe a))
  3.  
  4. result :: Parsed a -> PMaybe a
  5. result (Parsed f) = snd (f "")
  6.  
  7. fails :: Parsed a -> Bool
  8. fails (Parsed f) = isError (snd (f "")) where
  9.         isError (PError _) = True
  10.         isError (PJust _) = False
  11.  
  12. instance Monad Parsed where
  13.         return x = Parsed (\s -> (s, PJust x))
  14.         (Parsed v) >>= f = Parsed f_ where
  15.                 f_ s = do_f (v s) where
  16.                         do_f (str, PJust x) = app (f x) s where
  17.                                 app (Parsed f') = f'                           
  18.                         do_f (str, PError x) = (str, PError x)
  19.  
  20. setError :: String -> Parsed ()
  21. setError str = Parsed (\_ -> (str, PJust ()))
  22.  
  23. addError :: String -> Parsed ()
  24. addError str = Parsed (\s -> (s ++ " " ++ str, PJust()))
  25.  
  26. getError :: Parsed String
  27. getError = Parsed (\s -> (s, PJust s))
  28.  
  29. throwError :: Parsed a
  30. throwError = Parsed (\s -> (s, PError s))
  31.  
  32. class Expression a where
  33.         parse :: String -> Parsed (a, String)
  34.         eval :: a -> Float
  35.  
  36. trim :: String -> String
  37. trim (' ' : xs) = xs
  38. trim x = x
  39.  
  40. parseStr :: String -> String -> Parsed String
  41. parseStr p str = parseStr_ (f p str) where
  42.         parseStr_ Nothing = do throwError
  43.         parseStr_ (Just l) = do return (trim l)
  44.         f [] [] = Just []
  45.         f _ [] = Nothing
  46.         f [] s = Just s
  47.         f (x : xs) (y : ys) | x == y = (f xs ys)
  48.                 | otherwise = Nothing
  49.  
  50. parseOr :: Parsed a -> Parsed a -> Parsed a
  51. parseOr (Parsed l) (Parsed r) = Parsed f where
  52.         f s = do_l (l s) where
  53.                 do_l (_, PJust xl) = l s
  54.                 do_l (_, PError errl) = do_r (r s) where
  55.                         do_r (_, PJust xr) = r s
  56.                         do_r (_, PError errr) = ("", PError (errl ++ " and " ++ errr))
  57.  
  58. parseOrList :: [Parsed a] -> Parsed a
  59. parseOrList [] = do throwError
  60. parseOrList (x : y : []) = parseOr x y
  61. parseOrList (x : xs) = parseOr x (parseOrList xs)
  62.  
  63. parseOneOf :: [(String, a)] -> String -> Parsed (a, String)
  64. parseOneOf [] _ = do throwError
  65. parseOneOf _ [] = do throwError
  66. parseOneOf ((s, v) : xs) str = parseOr x x_ where
  67.         x = do
  68.                 l <- parseStr s str
  69.                 return (v, l)
  70.         x_ = do
  71.                 (r, l) <- parseOneOf xs str
  72.                 return (r, l)
  73.  
  74. parseVal :: String -> Parsed (Float, String)
  75. parseVal [] = do
  76.         addError " can't parse value from empty string"
  77.         throwError
  78. parseVal str = getVal (readsPrec 0 str) where
  79.         getVal [] = do
  80.                 addError (" can't parse value from " ++ str)
  81.                 throwError
  82.         getVal ((x, r) : _) = do return (x, trim r)
  83.  
  84. genericParse :: String -> [(String, Float -> Float -> Float)] -> (String -> Parsed (Float, String)) -> Parsed (Float, String)
  85. genericParse str bin_ops cont = do
  86.         (v, l) <- cont str
  87.         repeatParse v l where
  88.                 repeatParse v_ l_ =
  89.                         if (fails (parseNext v_ l_)) then
  90.                                 return (v_, l_)
  91.                         else
  92.                                 do
  93.                                         (nv, nl) <- parseNext v_ l_
  94.                                         repeatParse nv nl where
  95.                                                 parseNext _v_ _l_ = do
  96.                                                         (f, l2) <- parseOneOf bin_ops _l_
  97.                                                         (v2, l3) <- cont l2
  98.                                                         return (f _v_ v2, l3)
  99.  
  100. exprOps :: [(String, Float -> Float -> Float)]
  101. exprOps = [("+", (+)), ("-", (-))]
  102. parseExpr :: String -> Parsed (Float, String)
  103. parseExpr str = genericParse str exprOps parseFactor
  104.  
  105. factorOps :: [(String, Float -> Float -> Float)]
  106. factorOps = [("*", (*)), ("/", (/))]
  107. parseFactor :: String -> Parsed (Float, String)
  108. parseFactor str = genericParse str factorOps parseTerm
  109.  
  110. parseTerm :: String -> Parsed (Float, String)
  111. parseTerm str = parseOrList [pval, pfun, pbrack, pmin] where
  112.         pval = do
  113.                 (v, l) <- parseVal str
  114.                 return (v, l)
  115.         pfun = do
  116.                 (v, l) <- parseFunc str
  117.                 return (v, l)
  118.         pbrack = do
  119.                 l <- parseStr "(" str
  120.                 (v, l2) <- parseExpr l
  121.                 l3 <- parseStr ")" l2
  122.                 return (v, l3)
  123.         pmin = do
  124.                 l <- parseStr "-" str
  125.                 (v, l2) <- parseTerm l
  126.                 return (-v, l2)
  127.  
  128. unaryFuncs :: [(String, Float -> Float)]
  129. unaryFuncs = [("ln", log), ("sin", sin), ("cos", cos), ("sqrt", sqrt)]
  130. parseUnaryFunc :: String -> Parsed (Float, String)
  131. parseUnaryFunc str = do
  132.         (f, l1) <- parseOneOf unaryFuncs str
  133.         l2 <- parseStr "(" l1
  134.         (v, l3) <- parseExpr l2
  135.         l4 <- parseStr ")" l3
  136.         return (f v, l4)
  137.  
  138. binaryFuncs :: [(String, Float -> Float -> Float)]
  139. binaryFuncs = [("add", (+)), ("sub", (-)), ("mul" , (*)), ("div", (/)), ("pow", (**))]
  140. parseBinaryFunc :: String -> Parsed (Float, String)
  141. parseBinaryFunc str = do
  142.         (f, l1) <- parseOneOf binaryFuncs str
  143.         l2 <- parseStr "(" l1
  144.         (v1, l3) <- parseExpr l2
  145.         l4 <- parseStr "," l3
  146.         (v2, l5) <- parseExpr l4
  147.         l6 <- parseStr ")" l5
  148.         return (f v1 v2, l6)
  149.  
  150. parseFunc :: String -> Parsed (Float, String)
  151. parseFunc str = parseOr un bin where
  152.         un = parseUnaryFunc str
  153.         bin = parseBinaryFunc str
  154.  
  155. calc :: String -> IO ()
  156. calc str = showResult (result (parseExpr str)) where
  157.         showResult (PJust (x, r)) = do putStrLn (str ++ " = " ++ (show x))
  158.         showResult (PError e) = do putStrLn e
RAW Paste Data
We use cookies for various purposes including analytics. By continuing to use Pastebin, you agree to our use of cookies as described in the Cookies Policy. OK, I Understand
 
Top