module IO where {

import IOType;
import IOParser;

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

インタプリタ（入出力文）

* ST.hs +
* 入出力文の導入

 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
       | fn Ident -> Expr 
       | if Expr then Expr else Expr
       | set Expr | get
       | while Expr do Expr
       | begin ExprSeq 
       | read | write Expr -- for I/O
 ExprSeq -> Expr end
          | Expr; ExprSeq
 Decl -> Ident = Expr

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


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

 インタプリタ

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

type Env = [(String, Value)];

-- lookup' :: Eq a =>  a -> [(a, b)] -> b;
lookup' :: String -> [(String, a)] -> a;
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 h) ->
                             interp x e `bindM` \ y ->
                             h y;
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);
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 (SetX m1) e         = interp m1 e `bindM` \ v ->
                             setX v;
interp (SetY m1) e         = interp m1 e `bindM` \ v ->
                             setY v;
interp GetX e              = getX;
interp GetY e              = getY;
interp (Begin es) e 	   = case es of {
                    	   	[e1]   -> interp e1 e;
                    	   	f:fs  -> interp f e `bindM` \ _ ->
                    	   		 interp (Begin fs) e 
                    	     };
interp (While e1 e2) e     = interp e1 e `bindM` \ (Bool b) ->
                             if b then interp e2 e `bindM` \ _ ->
                                       interp (While e1 e2) e
                                  else unitM Unit;
interp  Read e             = readM;
interp (Write m1) e 	   = interp m1 e `bindM` \ v ->
                    	     writeM v;


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),
	   ("cons", myPair), ("isNull", myIsUnit),
           ("head", myFst), ("tail", mySnd),
	   ("nil", Unit),
	   ("++", myStrAppend), ("toString", myToString)	   
	  ];
   
run :: String -> String -> String;
run str i =
    let { (_, (_, _, o)) =  (interp (myParse str) initEnv ((Unit, Unit), i, "")) }
    in o ;

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

-- for example,
{-
  run ("let sq = \\ x -> if x>0 then x*x else 0-x*x in "++
       "let r = sq 2 in                                "++
       "write r                                        ") ""  
-}
}