module ErrST where {

  import ErrSTType;
  import ErrSTParser;

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

  インタプリタ

  * Util1 + エラーメッセージ + 状態

   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
         | fail Expr
         | setX Expr | getX
         | setY Expr | getY
         | while Expr do Expr
         | begin ExprSeq 
   ExprSeq -> Expr end
            | Expr; ExprSeq
   Decl -> Ident = Expr

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

  type Env = [(String, Value)];

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

  interp :: Expr -> Env -> M Value;
  {- interpの定義を考えてください  -}

  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 (\ v -> 
    case v of {
      Pair v1 v2 -> unitM v1;
      _          -> failM "Pair expected"
    });

  mySnd = Fun (\ v -> 
    case v of {
      Pair v1 v2 -> unitM v2;
      _          -> 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),
             ("cons", myPair), ("isNull", myIsUnit),
             ("head", myFst), ("tail", mySnd),
             ("nil", Unit),
             ("++", myStrAppend), ("toString", myToString)           
            ];

  run :: String -> String;
  run str = case interp (myParse str) initEnv (Unit, Unit) of {
              Success (a, _) -> showValue a;
              Failure str    -> "Error: " ++ str 
            };

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

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

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