{----------------------------------------------------------------------

インタプリタ

* 基本

 Expr -> Expr || Expr | Expr && Expr
       | Expr == Expr | Expr /= Expr | Expr < Expr | Expr <= Expr
       | Expr >= Expr | Expr > Expr
       | Expr ++ Expr  --- 文字列の連接
       | Expr * Expr | Expr / Expr 
       | Expr + Expr | Expr - Expr
       | Expr Expr 
       | Const
       | ( Expr )
       | Ident
       | let Decl in Expr
       | letrec Decl in Expr
       | \ Ident -> Expr 
       | if Expr then Expr else Expr
 Decl -> Ident = Expr

 ----------------------------------------------------------------------}

module Util1 where

import Util1Type
import Util1Parser

type Env = [(String, Value)]

lookup' :: Eq a =>  a -> [(a, b)] -> b
lookup' x ((n,v):rest) = if n==x then v else lookup' x rest

interp :: Expr -> Env -> M Value
interp (Const c) e         = unitM c
interp (Var x)   e         = unitM (lookup' x e)
interp (Let (x, m) n) e    = interp m e `bindM` \ v ->  
                             interp n ((x,v):e)
interp (App f x) e         = interp f e `bindM` \ (Fun g) ->
                             interp x e `bindM` \ y ->
                             g y  
interp (Lambda x m) e      = unitM (Fun (\ v -> interp m ((x,v):e)))
interp (If e1 e2 e3) e     = interp e1 e `bindM` \ (Bool b) ->
                             if b then interp e2 e
                                  else interp e3 e
interp (Letrec (x, m) n) e 
  = mfixU (\ v -> interp m ((x, Fun v):e) `bindM` \  (Fun f) ->
                  unitM f) `bindM` \ v  ->
    interp n ((x, Fun v):e)


binop op  = Fun (\ (Num c) -> unitM (Fun (\ (Num d) -> unitM (Num (op c d)))))
binop2 op = Fun (\ (Num c) -> unitM (Fun (\ (Num d) -> unitM (Bool (op c d)))))

myPair   = Fun (\ v1 -> unitM (Fun (\ v2 -> unitM (Pair v1 v2))))
myFst    = Fun (\ (Pair v1 v2) -> unitM v1)
mySnd    = Fun (\ (Pair v1 v2) -> unitM v2)
myIsPair = Fun (\ v -> case v of 
                         Pair _ _ -> unitM (Bool True)
                         _        -> unitM (Bool False))
myIsUnit = Fun (\ v -> case v of 
                         Unit -> unitM (Bool True)
                         _    -> unitM (Bool False))

myToString  = Fun (\ v -> unitM (Str (showValue v)))
myStrAppend = Fun (\ v1 -> unitM (Fun (\ v2 ->
              unitM (Str (showValue v1 ++ showValue v2)))))

initEnv = [("+", binop (+)), ("-", binop (-)),
           ("*", binop (*)), ("/", binop (/)),
           ("%", binop (\ x y -> fromInteger (round x `rem` round y))),
           ("not", Fun (\ (Bool b) -> unitM (Bool (not b)))), 
           ("==", binop2 (==)), ("/=", binop2 (/=)),
           (">", binop2 (>)), (">=", binop2 (>=)),
           ("<", binop2 (<)), ("<=", binop2 (<=)),
           ("True", Bool True), ("False", Bool False),
           ("pair", myPair), ("isPair", myIsPair), 
           ("Unit", Unit), ("isUnit", myIsUnit),
           ("fst", myFst), ("snd", mySnd),
           ("++", myStrAppend), ("toString", myToString)           
          ]
   
run :: String -> String
run str = showValue (interp (myParse str) initEnv)

main :: IO ()
main = interact run

load :: String -> IO ()
load path = readFile path >>= \ prog ->
            putStrLn (run prog)

-- for example,
-- run "letrec fact = \\ n -> if n==0 then 1 else n*fact(n-1) in fact 9"