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

インタプリタ（入出力文）

* ST.hs +
* 入出力文の導入

 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
       | fn Ident -> Expr 
       | if Expr then Expr else Expr
       | set Expr | get
       | while Expr do Expr
       | begin ExprSeq 
       | read | write Expr -- for I/O
 ExprSeq -> Expr end
          | Expr; ExprSeq
 Decl -> Ident = Expr

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

 ----------------------------------------------------------------------}
module IO where {

import Text.ParserCombinators.Parsec;
import Text.ParserCombinators.Parsec.Expr;
import Token;

data Value = Num Double | Bool Bool | Str String | Char Char
           | Fun (Value -> M Value) | Pair Value Value | Unit;

-- Value値を表示するために必要
instance Show Value where {
  showsPrec p (Num d)  = showParen (p>8) (showString "Num " . shows d);
  showsPrec p (Bool b) = showParen (p>8) (showString "Bool " . shows b);
  showsPrec p (Str d)  = showParen (p>8)
                         (showString "Str " . showChar '"' . showString d. showChar '"');
  showsPrec p (Char c) = showParen (p>8) (showChar '\'' . showChar c . showChar '\'');
  showsPrec p (Fun f)  = showParen (p>8) (showString "Fun <function>");
  showsPrec p (Pair v1 v2) = showParen (p>8) (showChar '(' . showsPrec 0 v1 .
                                              showString ", " . showsPrec 0 v2 .
                                              showChar ')');
  showsPrec p Unit     = showString "Unit" 
};

showValue (Num d)   = show d;
showValue (Bool b)  = show b;
showValue (Str str) = str;
showValue (Char c)  = [c];
showValue (Fun _)   = "<function>";
showValue (Pair v1 v2) = "("++show v1++", "++show v2++")";
showValue Unit      = "";

-- Exprの抽象構文
type Decl = (String, Expr);

data Expr = Const Value | Let Decl Expr | Var String  
          | Lambda String Expr | App Expr Expr | If Expr Expr Expr 
          | Letrec Decl Expr
          | Get | Set Expr
          | While Expr Expr | Begin [Expr] 
          | Read | Write Expr -- for I/O
            deriving Show;

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

op2 name = \ x y -> App (App (Var name) x) y;

table = [
	 [ Infix (do { try (symbol "*"); return (op2 "*")}) AssocLeft,
	   Infix (do { try (symbol "/"); return (op2 "/")}) AssocLeft,
	   Infix (do { try (symbol "%"); return (op2 "%")}) AssocLeft
	 ],
	 [ Infix (do { try (symbol "+"); return (op2 "+")}) AssocLeft,
	   Infix (do { try (symbol "-"); return (op2 "-")}) AssocLeft
	 ],
	 [ Infix (do { try (symbol "++"); return (op2 "++")}) AssocLeft ],
	 (map (\ op -> Infix (do { try (symbol op); return (op2 op)})
	                     AssocNone)
	  ["==", "/=", "<", "<=", ">=", ">"]),
	 [ Infix (do { try (symbol "&&");
		       return (\ x y -> If x y (Const (Bool False))) })
	   AssocRight
	 ],
	 [ Infix (do { try (symbol "||");
		       return (\ x y -> If x (Const (Bool True)) y) })
	   AssocRight
	 ]
	];


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 <- stringLiteral;
		   return (Const (Str t))
		  })
	      <|>
              (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 "letrec";
--		    decls <- parseDecls;
		    decl <- parseDecl;
		    reserved "in";
		    expr  <- parseExpr;
		    return (Letrec decl expr)
		  })
	      <|>
	      (do { (reserved "fn" <|> reservedOp "\\");
		    id <- identifier;
		    reservedOp "->";
		    e <- parseExpr;
		    return (Lambda id e)
		  })
	      <|>
	      (do {
		   reserved "if";
		   e1 <- parseExpr;
		   reserved "then";
		   e2 <- parseExpr;
		   reserved "else";
		   e3 <- parseExpr;
		   return (If e1 e2 e3)
		  })
	      <|>
	      (do {
		   reserved "set";
		   e <- parseExpr;
		   return (Set e)
		  })
	      <|>
	      (do {
		   reserved "get";
		   return Get
		  })	      
	      <|>
	      (do {
		   reserved "while";
		   e1 <- parseExpr;
		   reserved "do";
		   e2 <- parseExpr;
		   return (While e1 e2)
		  })
	      <|>
	      (do {
		   reserved "begin";
		   es <- parseExprs;
		   reserved "end";
		   return (Begin es)
		  })
	      <|>
	      (do {
		   reserved "read";
		   return Read
		  })

	      <|>
	      (do {
		   reserved "write";
		   e <- parseExpr;
		   return (Write e)
		  })

;

parseExprs = sepBy1 parseExpr semi;

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

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

 インタプリタ

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

type State = (Value, String, String);
type M a = State -> (a, State);

unitM :: a -> M a;
unitM a = \ s -> (a, s);

bindM :: M a -> (a -> M b) -> M b;
m `bindM` k = \ s0 -> let { (a, s1) = m s0 } in k a s1;

failM :: String -> M Value;
failM str = unitM (Str str);

--     by Daniel P. Friedman and Amr Sabry
mfixU :: ((a -> M b) -> M (a -> M b)) -> M (a -> M b);
mfixU e = unitM (\ a -> mfixU e `bindM` \ v -> v a) `bindM` \ v ->
          e v;

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;

updateM :: Value -> M Value;
updateM v = \ (s, i, o) -> (Unit, (v, i, o)); 

readM :: M Value;
readM =  \ (s, c:cs, o) -> (Char c, (s, cs, o)); 

writeM :: Value -> M Value;
writeM v =  \ (s, i, o) -> (Unit, (s, i, o++showValue v)); 

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` \  v1 ->
                                    case v1 of { 
                                      Fun f -> unitM f; 
                                      _     -> unitM (\ _ -> failM "function expected") 
                                               {- 本物の failMではないので
					          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 (Set e1) e = interp e1 e `bindM` \ v ->
                    updateM v;
interp Get e = \ (s, i, o) -> (s, (s, i, o));
interp (Begin es) e = case es of {
                    	[e1]   -> interp e1 e;
                    	f:fs  -> interp f e `bindM` \ _ ->
                    		 interp (Begin fs) e 
                      };
interp (While e1 e2) e = interp e1 e `bindM` \ v ->
			 case v of {
                       	   Bool b -> if b then interp e2 e `bindM` \ _ ->
                       	   	             interp (While e1 e2) e
                       	                  else unitM Unit;
                           _      -> failM "Boolean expected"
                         };
interp Read e = readM;
interp (Write m1) e = interp m1 e `bindM` \ v ->
                      writeM v;

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),
	   ("cons", myPair), ("isNull", myIsUnit),
           ("head", myFst), ("tail", mySnd),
	   ("nil", Unit),
	   ("++", myStrAppend), ("toString", myToString)	   
	  ];
   
myParse :: String -> Expr;
myParse str = case
	        (parse (do {whiteSpace; s<- parseExpr; eof; return s }) "" str)
	      of {
                Left err -> Const (Str ("parse error at " ++ show err));
	        Right x  -> x
	      }
;

run :: String -> String -> String;
run str i =
    let { (_, (_, _, o)) =  (interp (myParse str) initEnv (Unit, i, "")) }
    in o ;

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

-- for example,
{-
  run ("let sq = fn x -> if x>0 then x*x else 0-x*x in "++
       "let r = sq 2 in                                "++
       "write r                                        ") ""  
-}
}