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

インタプリタ

* Continuationのモナド（breakとcontinue）


 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
       | set | get
       | let Ident = Expr in Expr
       | letrec Decl in Expr
       | fn Ident -> Expr 
       | if Expr then Expr else Expr
       | while Expr do Expr
       | begin LabeledExprSeq 
       | break | continue | abort
       | goto Ident
       | callcc Expr

LabeledExprSeq -> LabeledExpr end
                | LabeledExpr; LabeledExprSeq

LabeledExpr -> Expr | Ident : Expr 
 ----------------------------------------------------------------------}
module Cont where {

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

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

-- 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 (Cont f) = showParen (p>8) (showString "Cont <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 (Cont _)  = "<continuation>";
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 
          | While Expr Expr | Begin [LabeledExpr] | Get | Set Expr
          | Break | Continue | Abort | Goto String | Callcc Expr
            deriving Show;

-- data Maybe a = Just a | Nothing;
type LabeledExpr = (Maybe String, Expr);

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

  構文解析部

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

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 <- parseLabeledExprs;
		   reserved "end";
		   return (Begin es)
		  })
	      <|>
	      (do {
		   reserved "break";
		   return Break
		  })
	      <|>
	      (do {
		   reserved "continue";
		   return Continue
		  })
	      <|>
	      (do {
		   reserved "abort";
		   return Abort
		  })
	      <|>
	      (do {
		   reserved "goto";
   	           id <- identifier;
                   return (Goto id)
		  })
	      <|>
	      (do {
		   reserved "callcc";
	           e <- parseExpr;
                   return (Callcc e)
		  })
;

parseLabeledExprs = sepBy1 parseLabeledExpr semi;

parseLabeledExpr = try (do { id <- identifier;
                         reservedOp ":";
                         e  <- parseExpr;
                         return (Just id, e)
                    })
	           <|>
                   (do { e  <- parseExpr;
                         return (Nothing, e)
                    })
;

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


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

 インタプリタ

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

type Env = [(String, Value)]  ;

-- Continuation
type K r a = (a -> r) -> r;

unitK :: a -> K r a;
unitK a = \ c -> c a;

bindK :: K r a -> (a -> K r b) -> K r b;
m `bindK` k = \ c -> m (\ a -> k a c); 

abortK :: r -> K r a;
abortK v = \ c -> v;

callccK :: ((a -> K r b) -> K r a) -> K r a;
callccK h = \ c -> let { k a = \ d -> c a } in h k c;

type M a = K Result a;

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

bindM :: M a -> (a -> M b) -> M b ;
bindM = bindK;

failM :: String -> M a;
failM message = abortK (\ s -> Str ("failure: "++message));

callccM :: ((a -> M b) -> M a) -> M a;
callccM = callccK;

getM :: M Value;
getM = \ c s -> c s s;

updateM :: Value -> M Value;
updateM v = \ c s -> c Unit v;

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");

abortM :: (State -> State) -> M a;
abortM st = abortK st;

-- see Recursion is a Computational Effect 
--     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;
        -- = e (\ a -> mfixU e `bindM` \ v -> v a)
{-
mfixU2 :: ((a -> M b, c -> M d) -> M (a -> M b, c -> M d)) -> M (a -> M b, c -> M d);
mfixU2 e = e (\ a -> mfixU2 e `bindM` \ (x, _) -> x a,
	      \ c -> mfixU2 e `bindM` \ (_, y) -> y c);
-}

-- letrecで相互再帰を許す場合に使用する。
-- nは束縛の個数
mfixUL :: Int -> ([a -> M b] -> M [a -> M b]) -> M [a -> M b];
mfixUL n e = 
   let {
      aux k = if k>=n then []
              else (\ a -> mfixUL n e `bindM` \ vs -> (vs !! k) a) : aux (k+1)
   } in e (aux 0);

{-
vfix :: ((a -> b) -> a -> b) -> a -> b;
vfix f = \ v -> f (vfix f) v;

vfix2 :: ((a -> b,c -> d) -> (a -> b,c -> d)) -> (a -> b,c -> d);
vfix2 f =(\ v -> fst (f (vfix2 f)) v, \ v -> snd (f (vfix2 f)) v);

vfixL :: Int -> ([a -> b] -> [a -> b]) -> [a -> b];
vfixL n f =
    let {
      aux k = if k>=n then []
	              else (\ v -> (f (vfixL n f) !! k) v) : aux (k+1)
    } in aux 0; 
-}

interpLabeledExpr :: LabeledExpr -> Env -> (Env, Value -> Result) -> (Env, Value -> Result);
interpLabeledExpr (Just id, e) env (xs, c2) = let { c1 = \ _ -> interp e env c2 } in ((id, Cont c1):xs, c1);
interpLabeledExpr (Nothing, e) env (xs, c2) = let { c1 = \ _ -> interp e env c2 } in (xs, c1);

interpLabeledExprSeq :: [LabeledExpr] -> Env -> (Value -> Result) -> (Env, Value -> Result);
interpLabeledExprSeq les env c = foldr (\ le (e, k) -> interpLabeledExpr le env (e, k)) ([], c) les;

interp :: Expr -> Env -> M Value;
interp (Const c)  e = unitM c;
interp (Var x)    e = lookupM x e;
interp (Let (x, m) n) e = interp m e `bindM` \ v  ->  
                          interp n ((x,v):e);
{-
-- Continuationのmonadでmfixは定義できない
-- cf. Recursive Monadic Bindings 
--     by Levent Erk\"ok and John Launchbury

interp (Letrec (x, m) n) e = mfix (\ v -> 
                                   interp m ((x,v):e)) `bindM` \ v  ->
                             interp n ((x,v):e);

-- 代わりに関数の再帰のみ許すmfixUを使用する
-}

interp (Letrec (x, m) n) e = mfixU (\ v -> 
                                    interp m ((x, Fun v):e) `bindM` \  v1 ->
                                    case v1 of { 
                                      Fun f -> unitM f; 
                                      _     -> failM ("function expected:" ++ showValue v1 ++ ":.") }) `bindM` \ v  ->
                             interp n ((x, Fun v):e);

interp (App f x) e  = interp f e `bindM` \ g -> 
                      case g of {
                    	Fun h -> interp x e `bindM` \ y ->
                    		 h y;
                    	v     -> failM ("App: Function expected:"++ showValue v ++":.") };    
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 = getM;

interp (Begin les) e = \ c -> let { (e', c1) = interpLabeledExprSeq les (e'++e) c } in c1 Unit;
{-
interp (Begin es) e = case es of {
                        [(_, f)]   -> interp f e;
                        (_, f):fs  -> interp f e `bindM` \ _ ->
                                      interp (Begin fs) e }; 
-}

interp (While e1 e2) e =  
  \ c1 -> 
  let { env1 = ("break", Cont c1) : e } in 
  interp e1 e (\ v ->
  case v of { 
     Bool b -> if b then 
                    let { c2 = \ _ -> interp (While e1 e2) e c1 } in
                    let { env2 = ("continue", Cont c2) : env1 } in
                    interp e2 env2 c2
               else c1 (Bool True);
     _      -> abortK (\ s -> Str "Boolean expected") c1 });
interp Break e = \ c0 -> lookupM "break" e (\ (Cont c) -> 
                         c (Bool False));
interp Continue e = \ c0 -> lookupM "continue" e (\ (Cont c) -> 
                            c (Bool False));
interp Abort e = abortM (\ s -> s);
{-
interp (Callcc e) = \ env c0 -> 
                    interp e env (\ x ->
                    case x of Fun f -> f (Fun (\ v env1 c1 -> c0 v)) env c0
                              _     -> failM ("Callcc: Function expected")
                                              env c0);
-}
interp (Callcc e1) e = interp e1 e `bindM` \ x ->
                       case x of { Fun f -> callccM (\ k -> f (Fun k));
                                   _     -> failM ("Callcc: Function expected") };
interp (Goto label) e = \ c0 -> lookupM label e (\ (Cont c) -> 
                                c (Bool False));
               
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" });
myTriple   = Fun (\ v1 -> unitM (Fun (\ v2 -> unitM (Fun (\ v3 ->
             unitM (Pair v1 (Pair v2 v3)))))));
myFst3    = Fun (\ v -> case v of {
                         Pair v1 v2 -> unitM v1;
                         _          -> failM "Triple expected" });
mySnd3    = Fun (\ v -> case v of {
                        Pair v1 (Pair v2 _) -> unitM v2;
                        _                   -> failM "Triple expected" });
myThd3    = Fun (\ v -> case v of {
                        Pair v1 (Pair v2 v3) -> unitM v3;
                        _                    -> failM "Triple expected" });
myToString = Fun (\ v -> unitM (Str (showValue v)));
myStrAppend = Fun (\ v1 -> unitM (Fun (\ v2 ->
              unitM (Str (showValue v1 ++ showValue 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) });


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),
	   ("Unit", Unit), ("isUnit", myIsUnit), 
           ("pair", myPair), ("fst", myFst), ("snd", mySnd), 
           ("isPair", myIsPair), 
           ("triple", myTriple),
           ("fst3", myFst3), ("snd3", mySnd3), ("thd3", myThd3),
           ("++", 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;
run str = showValue (interp (myParse str) initEnv (\ v s -> v) Unit);
	    
main :: IO ();
main = interact run;

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

load0 :: String -> IO ();
load0 path = readFile path >>= \ prog ->
    	     putStr (show (myParse prog));

-- for example,
{- 
  run ("let fact = fn n -> "++
       "  begin "++
       "    set (pair 1 n); "++
       "    while snd get > 0 do begin"++
       "      let r = fst get in "++
       "      let n = snd get in "++
       "      set (pair (r*n) (n-1)); "++
       "    end; "++
       "    fst get; "++
       "  end in "++
       "fact 9 ")
 -}
}