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

インタプリタ（関数）

* Var + 
* 関数の導入

 Expr -> Expr * Expr 
       | Expr + Expr 
       | Expr Expr 
       | Const
       | ( Expr )
       | Ident
       | let Ident = Expr in Expr
       | fn Ident -> Expr 

 ----------------------------------------------------------------------}
module Fun where {
import Text.ParserCombinators.Parsec;
import Text.ParserCombinators.Parsec.Expr;
import Token;

data Value = Num Double | Fun (Value -> M Value);

-- Value値を表示するために必要
instance Show Value where {
  showsPrec p (Num d) = showParen (p>8) (showString "Num ". shows d);
  showsPrec p (Fun f) = showParen (p>8) (showString "Fun <function>")
};

showValue (Num d)   = show d;
showValue (Fun _)   = "<function>";

{-

インタプリタ

* Util1+関数の導入

-}

-- Exprの抽象構文
type Decl = (String, Expr);
data Expr = Mult Expr Expr | Add Expr Expr | Const Value
          | Let Decl Expr | Var String  
          | Lambda String Expr | App Expr Expr 
            deriving Show;

parseExpr = buildExpressionParser table parseFactor <?> "expression";

table = [
	 [ Infix (do { symbol "*"; return Mult }) AssocLeft],
	 [ Infix (do { symbol "+"; return Add }) AssocLeft]
	];

parseFactor = do {
		  es <- many1 parseAtomic;
		  return (foldl1 App es)
		 }
;

parseAtomic = parens parseExpr
              <|>
              (do { t <- naturalOrFloat;
		    return (case t of { Left i -> Const (Num (fromInteger i));
					Right d -> Const (Num d) }) })
	      <|>
              (do { t <- identifier; return (Var t) })
	      <|>
	      (do { reserved "let";
--		    decls <- parseDecls;
		    decl <- parseDecl;
		    reserved "in";
		    expr  <- parseExpr;
--		    return (Let decls expr)
		    return (Let decl expr)
		  })
	      <|>
	      (do { (reserved "fn" <|> reservedOp "\\");
		    id <- identifier;
		    reservedOp "->";
		    e <- parseExpr;
		    return (Lambda id e)
		  })
;

parseDecls = sepBy1 parseDecl semi;
parseDecl = do {
		i <- identifier;
		symbol "=";
		e <- parseExpr;
		return (i, e)
	       }
;

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

 インタプリタ

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


type Env = [(String, Value)];

lookup' :: Eq a =>  a -> [(a, b)] -> b;
lookup' x ((n,v):rest) = if n==x then v else lookup' x rest;

type M a = a;

{-
 -- Monadic Version

unitM :: a -> M a;
unitM a = a;

bindM :: M a -> (a -> M b) -> M b;
m `bindM` k = k m;

failM str = unitM (Num 0)

interp :: Expr -> Env -> M Value;
interp (Const c) e  = unitM c;
interp (Add m n) e  = interp m e `bindM` \ (Num c) ->
                      interp n e `bindM` \ (Num d) ->
                      unitM (Num (c+d));
interp (Mult m n) e = interp m e `bindM` \ (Num c) ->
                      interp n e `bindM` \ (Num d) ->
                      unitM (Num (c*d));
interp (Var x)    e  = unitM (lookup' x e);
interp (Let (x, m) n) e = interp m e `bindM` \ v  ->
                          interp n ((e,x):v);
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 -> interp m ((e,x):v)));
-}

 -- Non-Monadic Version
interp :: Expr -> Env -> Value;
interp (Const c) e  = c;
interp (Add m n) e  = let {
                        Num c = interp m e;
                        Num d = interp n e 
                      } in 
                      Num (c+d);
interp (Mult m n) e = let { 
                        Num c = interp m e;
                        Num d = interp n e 
                      } in 
                      Num (c*d);
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));

myParse :: String -> Expr;
myParse str = case
	        (parse (do {whiteSpace; s<- parseExpr; eof; return s }) "" str)
	      of {
                Left err -> Const (Num (1/0));
	        Right x  -> x
	      }
;

run :: String -> String;
run str = showValue (interp (myParse str) []);


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

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

-- for example                    
-- run "let sq = fn x -> x*x in sq (sq 2)"
}