home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / hugs101.zip / hugs101sc.zip / hugsdist / demos / expr.hs < prev    next >
Encoding:
Text File  |  1995-02-14  |  3.0 KB  |  90 lines
  1. -----------------------------------------------------------------------------
  2. -- Parsing simple arithmetic expressions using combinators in Hugs
  3. --
  4. -- Mark P. Jones, April 4, 1993
  5.  
  6. infixr 6 &&&
  7. infixl 5 >>>
  8. infixr 4 |||
  9.  
  10. type Parser a = String -> [(a,String)]
  11.  
  12. result       :: a -> Parser a
  13. result x s    = [(x,s)]
  14.  
  15. (|||)        :: Parser a -> Parser a -> Parser a
  16. (p ||| q) s   = p s ++ q s
  17.  
  18. (&&&)        :: Parser a -> Parser b -> Parser (a,b)
  19. (p &&& q) s   = [ ((x,y),s1) | (x,s0) <- p s, (y,s1) <- q s0 ]
  20.  
  21. (>>>)        :: Parser a -> (a -> b) -> Parser b
  22. (p >>> f) s   = [ (f x, s0) | (x,s0) <- p s ]
  23.  
  24. many         :: Parser a -> Parser [a]
  25. many p        = q where q = p &&& q >>> (\(x,xs) -> x:xs)
  26.                             |||
  27.                             result []
  28.  
  29. many1        :: Parser a -> Parser [a]
  30. many1 p       = p &&& many p >>> (\(x,xs) -> x:xs)
  31.  
  32. sat          :: (Char -> Bool) -> Parser Char
  33. sat p (c:cs)
  34.         | p c = [ (c,cs) ]
  35. sat p cs      = []
  36.  
  37. tok          :: String -> Parser String
  38. tok s cs      = loop s cs
  39.                 where loop ""     cs            = [(s,cs)]
  40.                       loop (s:ss) (c:cs) | s==c = loop ss cs
  41.                       loop _      _             = []
  42.  
  43. digit        :: Parser Int
  44. digit         = sat isDigit >>> \d -> ord d - ord '0'
  45.  
  46. number       :: Parser Int
  47. number        = many1 digit >>> foldl (\a x -> 10*a+x) 0
  48.  
  49. -- Original version:
  50. -- eval "1"          (540 reductions, 933 cells)
  51. -- eval "(1)"        (5555 reductions, 8832 cells)
  52. -- eval "((1))"      (50587 reductions, 80354 cells, 1 garbage collection)
  53. -- eval "(((1)))"    (455907 reductions, 724061 cells, 7 garbage collections)
  54. -- eval "1+2+3+4+5"  (1296 reductions, 2185 cells)
  55. -- eval "1+"         (828 reductions, 1227 cells)
  56.  
  57. {-
  58. expr   = term &&& tok "+" &&& expr >>> (\(x,(p,y)) -> x + y)  |||
  59.          term &&& tok "-" &&& expr >>> (\(x,(m,y)) -> x - y)  |||
  60.          term
  61.  
  62. term   = atom &&& tok "*" &&& term >>> (\(x,(t,y)) -> x * y)  |||
  63.          atom &&& tok "/" &&& term >>> (\(x,(d,y)) -> x / y)  |||
  64.          atom
  65. -}
  66.  
  67. atom   = tok "-" &&& number >>> (\(u,n) -> -n)                |||
  68.          number                                               |||
  69.          tok "(" &&& expr &&& tok ")" >>> (\(o,(n,c)) -> n)
  70.  
  71. -- Putting the initial prefix parser first:
  72. -- eval "1"           (96 reductions, 168 cells)
  73. -- eval "(1)"         (191 reductions, 335 cells)
  74. -- eval "((1))"       (283 reductions, 498 cells)
  75. -- eval "(((1)))"     (375 reductions, 661 cells)
  76. -- eval "1+2+3+4+5"   (472 reductions, 905 cells)
  77. -- eval "1+"          (124 reductions, 251 cells)
  78.  
  79. expr   = term &&& (tok "+" &&& expr >>> (\(p,y) -> (+y))       |||
  80.                    tok "-" &&& expr >>> (\(m,y) -> subtract y) |||
  81.                    result id) >>> \(n,f) -> f n
  82.  
  83. term   = atom &&& (tok "*" &&& term >>> (\(t,y) -> (*y))       |||
  84.                    tok "/" &&& term >>> (\(d,y) -> (`div` y))  |||
  85.                    result id) >>> \(n,f) -> f n
  86.  
  87. eval s = case expr s of ((x,""):_) -> x
  88.                         _          -> error "Syntax error in input"
  89.  
  90.