module Fun2 where {

import Fun2Type;
import Fun2Parser;

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

インタプリタ（関数）

* Fun.hs +
* If文の導入
* いくつかのプリミティブ関数を追加


 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 Ident = Expr in Expr
       | \ Ident -> Expr 
       | if Expr then Expr else 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;

{-
-- Monadic Version
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` \ g ->
                          case g of {
                            Fun h -> interp x e `bindM` \ y ->
                                     h y;
                       {-   _     -> failM "Function expected" -}
                          };
interp (Lambda x m) e   = unitM (Fun (\ v -> unitM (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" -}
                          }
-}

-- Non-Monadic Version
interp :: Expr -> Env -> Value;
interp (Const c) e      = c;
interp (Var x) e        = lookup' x e;
interp (Let (x, m) n) e = let { v = interp m e } in
                          interp n ((x,v):e);

interp (App f x) e      = case interp f e of { 
                            Fun g -> g (interp x e);
                         {- _     -> Str "error: Function expected" -}
                          };
interp (Lambda x m) e   = Fun (\ v -> interp m ((x,v):e));
 
interp (If e1 e2 e3) e  = case interp e1 e of {
                            Bool b -> if b then interp e2 e
                                           else interp e3 e;
                         {- _      -> Str "error: Boolean expected" -}
                          };

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 "let sq = \\ x -> if x>0 then x*x else 0-x*x in sq 2"
}