module Catch where {

import CatchType;
import CatchParser;

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

インタプリタ

* Err +
* エラー処理（catch）

 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
       | try Expr catch Expr
 Decl -> Ident = Expr

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

type Env = [(String, Value)];

lookupM :: String -> Env -> M Value;
lookupM x ((n,v):rest)  = if n==x then Success v else lookupM x rest;
lookupM x []            = Failure ("Variable: "++x++" is not found");

interp :: Expr -> Env -> M Value;
interp (Const c) e 	   = unitM c;
interp (Var x)   e 	   = lookupM 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` \ g ->
                   	     case g of {
                   	       Fun h -> interp x e `bindM` \ y ->
                   	                h y;
                   	       _     -> failM "Function expected."
                   	     };    
interp (Letrec (x, m) n) e = mfixU (\ v -> 
                                    interp m ((x, Fun v):e) `bindM` \  v1 ->
                                    case v1 of { 
                                      Fun f -> unitM f; 
                                      _     -> failM "function expected" 
                                    }) `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` \ v ->
                             case v of {
                               Bool b -> if b then interp e2 e
                           		   else interp e3 e;
                               _      -> failM "Boolean expected"
                             };
interp (Try e1 e2) e 	   = tryM (interp e1 e) (interp e2 e);
interp (Fail e1) e   	   = interp e1 e `bindM` \ v ->
                     	     failM (showValue v);

binop op =  Fun (\ v ->
              case v of {
                Num c -> unitM (Fun (\ w ->
                           case w of {
                             Num d -> unitM (Num (op c d));
                             _     -> failM "Number expected"
                           }));
                _     -> failM "Number expected"
              });

binop2 op =  Fun (\ v ->
	       case v of {
		 Num c -> unitM (Fun (\ w ->
			    case w of {
			      Num d -> unitM (Bool (op c d));
			      _     -> failM "Number expected"
                            }));
		 _     -> failM "Number expected"
               });

divop = Fun (\ v ->
              case v of {
                Num c -> unitM (Fun (\ w ->
                           case w of {
                             Num 0 -> failM "Division by 0";
                             Num d -> unitM (Num (c/d));
                             _     -> failM "Number expected"
                           }));
                _     -> failM "Number expected"
              });

myPair   = Fun (\ v1 -> unitM (Fun (\ v2 -> unitM (Pair v1 v2))));


myFst = Fun myFst' 
  where {
    myFst' (Pair v1 v2 ) = unitM v1;
    myFst' _             = failM "Pair expected"
  };

mySnd = Fun mySnd'
  where {
    mySnd' (Pair v1 v2) = unitM v2;
    mySnd' _            = failM "Pair expected"
  };

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 (*)), ("/", divop),
           ("%", 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 = showErr (interp (myParse str) initEnv);

main :: IO ();
main = interact run;

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

-- for example, 
{-
  run "try 1/0 catch 999999"
  run "try let fact = \\ n -> if n==0 then 1 else n*fact(n-1) in fact 9 catch 0"
 -}
}