module ContType where {

type State = (Value, Value, 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 
          | GetX | SetX Expr | GetY | SetY Expr | GetZ | SetZ Expr
          | While Expr Expr | Begin [LabeledExpr] 
          | Break | Continue | Abort | Goto String | Callcc Expr
            deriving Show;

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

-- 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), Unit, Unit));

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

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; 
-}


setX :: Value -> M Value;
setX v = \ k (x, y, z) -> k Unit (v, y, z); 

setY :: Value -> M Value;
setY v = \ k (x, y, z) -> k Unit (x, v, z);

setZ :: Value -> M Value;
setZ v = \ k (x, y, z) -> k Unit (x, y, v);


getX :: M Value;  
getX   = \ k (x, y, z) -> k x (x, y, z);

getY :: M Value;  
getY   = \ k (x, y, z) -> k y (x, y, z);

getZ :: M Value;  
getZ   = \ k (x, y, z) -> k z (x, y, z);

}