import IO
import Char
import Data.Map

main = do hSetBuffering stdout NoBuffering
          readEvalLoop Data.Map.empty

readEvalLoop env = do putStr ">>> "
                      s <- getLine
                      (result,newenv) <- return $ eval s env 
                      putStr result
                      readEvalLoop newenv

eval s env = case (tokenize s) of
             [] -> ("",env)
             ts -> let (rv,newenv) = (calculate ts env) in (show rv ++ "\n", newenv)

tokenize :: String -> [Token]
tokenize []                           = []
tokenize (c:cs) | isSpace(c)          = tokenize cs
                | c `elem` "=+-/*^()" = (Symbol c):(tokenize cs)
                | isDigit(c)          = readNumber [c] cs
                | isAlpha(c)         = readIdent [c] cs

readNumber num []                     = [Number (read num)]
readNumber num s@(c:cs) | c == '.'    = readDigits (num ++ [c]) cs
                        | isDigit(c)  = readNumber (num ++ [c]) cs
                        | True        = (Number (read num)):(tokenize s)

readDigits num []                     = [Number (read num)]
readDigits num s@(c:cs) | isDigit(c)  = readDigits (num ++ [c]) cs
                        | True        = (Number (read num)):(tokenize s)

readIdent name []                     = [Ident name]
readIdent name s@(c:cs) | isAlphaNum(c) = readIdent (name ++ [c]) cs
                        | otherwise   = (Ident name):(tokenize s)

data Token = Number Float
           | Symbol Char
           | Ident String

calculate [Number x] env = (x, env)
calculate ts env = case (reduce ts [0] env) of
                   (val, [], newenv) -> (val, newenv)

reduce :: [Token] -> [Integer] -> Data.Map.Map String Float -> (Float, [Token], Data.Map.Map String Float)
reduce [Number x] (p:ps) env = (x, [], env)
reduce (Symbol '(' : rest) (p:ps) env = reduce rest (0:p:ps) env
reduce (Number x : Symbol ')' : rest) (p:ps) env | p == 0 = reduce (Number x : rest) ps env
                                                 | p > 0  = (x, Symbol ')' : rest, env)
reduce (Symbol '-' : rest) (p:ps) env = let (x, zs, newenv) = reduce rest (priority 'u':ps) env
                                        in reduce (Number (-x) : zs) (p:ps) newenv
reduce (Number x : Symbol op : rest) (p:ps) env = if priority op < p || not (isRightAssoc op) && priority op == p
    then (x, Symbol op : rest, env)
    else let (y,zs,newenv) = reduce rest (priority op : ps) env
         in reduce (Number (arithmetic x op y) : zs) (p:ps) newenv
reduce (Ident v : Symbol '=' : rest) (p:ps) env = if priority '=' < p 
    then case Data.Map.lookup v env :: Maybe Float of
         Just x -> (x, Symbol '=' : rest, env) -- this is impossible, but let's handle it anyway
    else let (y,zs,ne) = reduce rest (priority '=' : ps) env
             newenv = Data.Map.insert v y ne
         in reduce (Ident v : zs) (p:ps) newenv
reduce (Ident v : rest) pps env = case Data.Map.lookup v env :: Maybe Float of
                                  Just x -> reduce (Number x : rest) pps env

priority op = case op of
              '=' -> 1
              '+' -> 2 ; '-' -> 2
              '*' -> 3 ; '/' -> 3
              'u' -> 4 -- unary minus
              '^' -> 5

isRightAssoc op | op == '^' = True
                | otherwise = False

arithmetic :: Float -> Char -> Float -> Float
arithmetic x '+' y = x + y
arithmetic x '-' y = x - y
arithmetic x '*' y = x * y
arithmetic x '/' y = x / y
arithmetic x '^' y = x ** y

type Env = Map String Float
type Result = String
type CalcS a = StateT Env IO a

readEvalLoop :: CalcS Result
eval :: String -> CalcS Result
calculate :: [Token] -> CalcS Float
reduce :: [Token] -> [Integer] -> CalcS (Float, [Token])

let (x,newenv) = foo z env in (bar x, newenv)

x <- foo z
return (bar x)

liftM bar (foo z)

foo = if blah then branchT else branchE
bar = case foobar of { pattern -> expr }

foo | blah      = branchT
    | otherwise = branchE

bar = expr
    where
            pattern = foobar

eval :: String -> CalcS Result
eval s
    | null tokens = return ""
    | otherwise   = liftM show (calculate tokens)
    where
        tokens = tokenize s

calculate :: [Token] -> CalcS Float
calculate [Number x] = return x
calculate ts         = liftM fst (reduce ts [0])

ident = many1 alphaNum

number = do n <- integer
            f <- fraction
                        return (fromInteger n + f)

integer = liftM toNum (many1 digit)
    where
            toNum = foldl (\x d -> 10*x + toInteger (digitToInt d)) 0

fraction = option 0.0 $ try $ do
                char '.'
                liftM toFrac (many1 digit)
        where
                toFrac = foldr (\x d -> (x + fromIntegral (digitToInt d))/10.0) 0

parser = makeTokenParser haskellStyle
ident = identifier parser
number = float parser
string = stringLiteral parser

buildExpressionParser
        [[op "*" (*) AssocLeft], [op "/" (/) AssocLeft],
         [op "+" (+) AssocLeft], [op "-" (-) AssocLeft]
    where
        op s f assoc = Infix (do{ string s; return f}) assoc

x <- foo z
return (bar x)

(foo z) >>= (\x -> return (bar x))

foo z >>= \x ->
return (bar x)

bindS(
    function(x) { return foo(z, x) },
        function(x) { return (returnS (bar(x))) } 
)

data CalcS a = StateT Env (ErrorT String IO) a

if param < 0
    then throwError "Negative" -- тут мы зовём метод MonadError
    else modify (param:)       -- тут мы зовём метод MonadState

In America, you execute a program.
In Soviet Russia, a program executes you!

Пишем в ивертированном стиле сами

Используем continuations

Пример: монада State

;; magic happens here
(define (reflect ma)
  (shift k (bind ma k)))

;; ordinary State monad operations, copied verbatim from Haskell's

(define (return x)
  (lambda (s) (cons x s)))

(define (bind m f)
  (lambda (s)
    (let* ((as1 (m s))
           (a (car as1))
           (s1 (cdr as1)))
      ((f a) s1))))

(define (put x)
  (reflect (lambda (_) (cons (void) x))))

(define (get)
  (reflect (lambda (s) (cons s s))))

(define (run-state m s0)
  ((reset (return (m))) s0))

;; tests

(define (test0) 45)

(define (test1)
  (let ((x (get)))
    (begin
      (put (+ x 5))
      (put (+ (get) (get)))
      0)))

(run-state test0 10) ;; prints (45 . 10)
(run-state test1 10) ;; prints (0 . 30)

Ссылки

(define (break) (shift k k))

(define (forrest)
  (reset
   (begin
     (display "before breakpoint 1")
     (newline)

     (display (format "value returned from breakpoint 1: ~a" (break)))
     (newline)

     (display "before breakpoints 2 & 3")
     (newline)

     (display (format "result of complex expression with breaks inside: ~a"
                      (+ 10 (* (break) 2) (break))))
     (newline)
     "final value")))

(define (run-forrest-run)
  (let* ((snapshot1 (forrest))
         (snapshot2 (snapshot1 "eat this"))
         (alternative-snapshot2 (snapshot1 "now eat that"))
         (snapshot3 (snapshot2 10))
         (alternative-snapshot3 (alternative-snapshot2 20))         
         (final-value (snapshot3 20))
         (alternative-final-value (alternative-snapshot3 40)))
    (begin
      (display (format "final value is: ~a" final-value))
      (newline)
      (display (format "alternative final value is also: ~a" final-value))
      (newline))))

before breakpoint 1
value returned from breakpoint 1: eat this
before breakpoints 2 & 3
value returned from breakpoint 1: now eat that
before breakpoints 2 & 3
result of complex expression with breaks inside: 50
result of complex expression with breaks inside: 90
final value is: final value
alternative final value is also: final value

def foo(f):
    items = getSomeItems()
    for item in items:
        f(item)
...
foo(yield)

L>data CalcS a = StateT Env (ErrorT String IO) a

L>if param < 0
L>    then throwError "Negative" -- тут мы зовём метод MonadError
L>    else modify (param:)       -- тут мы зовём метод MonadState

if param < 0
    then liftM $ throwError "Negative"
    else modify (param:)

К>>if param < 0
К>>    then liftM $ throwError "Negative"
К>>    else modify (param:)
К>>

instance (MonadError e m) => MonadError e (StateT s m) where
    throwError       = lift . throwError
    m `catchError` h = StateT $ \s -> runStateT m s
        `catchError` \e -> runStateT (h e) s

PM>def foo(f):
PM>    items = getSomeItems()
PM>    for item in items:
PM>        f(item)
PM>...
PM>foo(yield)
PM>

class shift(object):
  def __init__(self, func):
    def wrapper(*args, **kw):
      gen = func(*args, **kw)
      gen.next()
      return gen
    self.cons = wrapper()

  def __call__(self, item):
    self.cons.send(item)

def for_each(it, func):
  "Итеративная функция"
  for item in it:
    func(item)

def test():
  "Наши вычисления над итемами"
  while True:
    item = (yield)
    print item

#Запускаем "продолжения"
for_each(xrange(10), shift(test))

T>def test():
T>  "Наши вычисления над итемами"
T>  while True:
T>    item = (yield)
T>    print item
T>

T>Оно конечно не настоящие "продолжения" но вроде где-то рядом.

...
  while True:
    item = (yield)
...
[py]
в итератор.
Тогда бы test мог выглядеть совершенно невинно:
[py]
def test(it):
  for item in it:
    print item

@@metacont = lambda { |x|
    raise RuntimeError, "You forgot the top-level reset..."
}

def reset(&block)
    mc = @@metacont
    callcc { |k|
        @@metacont = lambda { |v|
            @@metacont = mc
            k.call v
        }
        x = block.call
        @@metacont.call x
    }
end

def shift(&block)
    callcc { |k|
        @@metacont.call block.call(lambda { |*v| reset { k.call *v } })
    }
end

def each_to_stream(collection)
  reset {
    collection.each { |v|
      shift { |k|
        lambda { |&block|
          block.call v
          k.call
        }
      }
    }
    nil
  }
end

def each_to_stream(collection)
        callcc { |k1|
                k3({
                        collection.each(lambda { |v|
                                callcc { |k2|
                                        {k3|k1}(lambda { |b|
                                                b(v)
                                                callcc { |k3|
                                                        k3(k2([]))
                                                }
                                        })
                                }
                        })
                        nil
                })
        }
end

#
# Вот этот код "вывернется" наружу, обернув примитивы State в bind.
#
def reflect(&m)
    shift { | k | bindM(m, k) }
end

#
# Следующие две функции - это реализация монады State.
#
def returnM(x)
    lambda { |s| [x,s] }
end

def bindM(m, f)
    lambda do |s|
        as1 = m.call s
        a  = as1[0]
        s1 = as1[1]
        f.call(a).call(s1)
    end
end

#
# Следующие две функции - простые примитивы для работы с монадой State.
#
def put(s)
    reflect { |_| [[], s] }
end

def get
    reflect { |s| [s,s] }
end

#
# Вот так мы разворачиваем состояние.
#
def run_state(s0, &m)
    (reset { returnM(m.call) }).call(s0)
end

#
# Пример использования
#
def testMe
    state = run_state(10) do
        x = get
        put(x + 5)
        put(get + get)
        0
    end

    print state[1]
end

testMe

div (x : int, y : int) : int
{
  call/cc (fun (return)
    {
      when (y = 0)
        return 0;
      x / y
    }
  )
}

fun (a) {
  ...
  div (x : int, y : int) : int
  {
    a
  }
  ...
}

reset (10 + (shift (foo => 1 + 2 + 3 + (foo 3))))

T>class shift(object):
T>  def __init__(self, func):
T>    def wrapper(*args, **kw):
T>      gen = func(*args, **kw)
T>      gen.next()
T>      return gen
T>    self.cons = wrapper()

T>  def __call__(self, item):
T>    self.cons.send(item)
T>

def shift(func):
    cons = func()
    cons.next()
    return cons.send()

VD>Тогда что понимать по повторить. Боюсь, что повтор на С, да и на С++ могут оказаться настолько "выразительным", что все кто это увидит будут долго и нецензурно выражаться .

get = reflect(get')
set = reflect(set')

reflect(m) = shift (f => m >>= f)

(B) (reset { return {
    x  = shift(f => (s => (s,s)) >>= f)
        shift(f => (_ => ((), x + 5)) >>= f)
        $1 = shift(f => (s => (s,s)) >>= f)
        $2 = shift(f => (s => (s,s)) >>= f)
        shift(f => (_ => ((), $1 + $2)) >>= f)
    }})

(C) (s => (s,s)) >>=
(x => (_ => ((), x + 5)) >>=
(_ => (s => (s,s)) >>=
($1 => (s => (s,s)) >>=
($2 => (_ => ((),$1 + $2))))))
[code]

Это ключевое место, обрати внимание как (B) преобразуется в (C).
Мы просто везде вместо f подставляем готовый контекст - как будто, мы выдернули первый shift, и вместо f подставили всё что осталось в reset-блоке, дальше в нём выдернули следующий shift и т.д. пока у нас не осталось ни одного shift-а.

Т.е

[code]
reset { q; shift(k => m(k)); shift(k => n(k)); p}

m(n({q;p}))

s0 => let (x, _) = get'(s0)      // (s0,s0)
          (_,s1) = put'(x+5)     // ((), s0+5)
                    ($1,_) = get'(s1)      // (s0+5,s0+5)
                    ($2,_) = get'(s1)      // (s0+5,s0+5)
             in ((), $1 + $2)          // ((), (s0+5)+(s0+5))

То есть 2+ получается после ужатия C#-ного кода до безоразия (объявления и выражения на одной строке, 150-символьные строки).