Concurrent Clean : [id:lethevert:20060801:p3]を作った

今度はCleanで。
同じような感じに書いたので、あまり変わり映えがしない気がする。
後で、Parserライブラリを使って書いてみよう。

module Main

import StdEnv, OptEnv

Start :: *World -> *World
Start w = w --> f input
  where
    f s = s --> parse --> snd --> eval
    input = "(begin\n"
        +++ "  (print (concat Hell \"o W\" \"orld!\"))\n"
        +++ "  (print \"1+2*3*4 = \" (+ 1 (* 2 3 4)))\n"
        +++ "  ((concat pri nt) ok))\n"

::Tree = Branch Tree Tree
       | Leaf String
       | NIL

str :: [Char] -> {#Char}
str s = {x \\ x <- reverse s}

parse :: {#Char} -> (Int, Tree)
parse input = parse [] 0
  where
    len = size input
    parse s i | i >= len
        = case s of
            [] = (i, NIL)
            _  = (i, Branch (Leaf (str s)) NIL)
    parse s i = p input.[i]
      where
        p '('
            = case s of
                [] = (i1, Branch t0 t1)
                _  = (i1, Branch (Leaf (str s)) (Branch t0 t1))
          where
            (i0, t0) = parse [] (inc i)
            (i1, t1) = parse [] i0
        p ')'
            = case s of
                [] = (inc i, NIL)
                _  = (inc i, Branch (Leaf (str s)) NIL)
        p '\"'
            = case s of
                [] = (i1, Branch t0 t1)
                _  = (i1, Branch (Leaf (str s)) (Branch t0 t1))
          where
            (i0, t0) = parseStr [] (inc i)
            (i1, t1) = parse [] i0
        p c | isSpace c
            = case s of
                [] = parse [] (inc i)
                _  = (i0, Branch (Leaf (str s)) t0)
          where
            (i0, t0) = parse [] (inc i)
        p c = parse [c:s] (inc i)

    parseStr s i = p input.[i]
      where
        p '\"' = (inc i, Leaf (str s))
        p '\\' = parseStr [input.[inc i]:s] (i+2)
        p c    = parseStr [c:s] (inc i)

eval :: Tree *World -> *World
eval t w # (f,w) = stdio w
           (_,f) = f --> evalArgs t
           (_,w) = fclose f w
         = w;
  where
    evalArgs (Branch t0 t1) f
        # (s0,f) = eval t0 f
          (s1,f) = evalArgs t1 f
        = (Branch s0 s1, f)
    evalArgs t f = (t, f)

    eval (t=:(Branch _ _)) f
        # (Branch (Leaf s) t, f) = evalArgs t f
        = apply s t f
      where
        apply "begin" t f = (last t, f)
          where
            last (Branch _ tr) = last tr
            last t = t
        apply "print" t f = print t f
          where
            print (Branch (Leaf s) tr) f = f --> fwrites s
                                             --> print tr
            print _ f = (Leaf "ok", f --> fwrites "\n")
        apply "concat" t f = (Leaf s, f)
          where
            s = {x \\ x <- concat t}
            concat (Branch (Leaf s) tr) = [x \\ x <-:s] ++ concat tr
            concat _ = []
        apply "+" t f = (Leaf (toString (add t)), f)
          where
            add (Branch (Leaf s) tr) = toInt s + add tr
            add _ = 0
        apply "*" t f = (Leaf (toString (mul t)), f)
          where
            mul (Branch (Leaf s) tr) = toInt s * mul tr
            mul _ = 1

    eval t f = (t,f)