module Rec where {

  import RecType;
  import RecParser;

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

  インタプリタ（関数+LetRec）

  * Fun2 +
  * LetRec（再帰的定義）の導入


   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

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

  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 (Letrec (x, m) n) e = mfixU (\ v -> 
                                 interp m ((x, Fun v):e) `bindM` \ (Fun f) -> 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` \ 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 (Letrec (x, m) n) e = let { 
                                 v  = interp m e1;
                                 e1 = (x,v):e 
                               } in interp n e1;
  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 "letrec fact = \\ n -> if n==0 then 1 else n*fact(n-1) in fact 9";
}