module ContType where {

type MyState = (Value, Value, Value);
type ST s a = s -> (a, s);

unitST :: a -> ST s a;
unitST a = \ s -> (a, s);

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

type Result = ST MyState Value;
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 (unitST (Str ("failure: "++message)));

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

abortM :: ST MyState Value -> 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 :: x -> K (ST (x, y, z) a) Value ;
setX v = \ k (x, y, z) -> k Unit (v, y, z); 

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

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


getX :: K (ST (x, y, z) a) x;
getX   = \ k (x, y, z) -> k x (x, y, z);

getY :: K (ST (x, y, z) a) y;
getY   = \ k (x, y, z) -> k y (x, y, z);

getZ :: K (ST (x, y, z) a) z;
getZ   = \ k (x, y, z) -> k z (x, y, z);

foo :: Integer -> K (ST (Integer, Integer, z) a) Integer;
foo n = setX 1 		       `bindK` \ _ ->
        setY n 		       `bindK` \ _ ->
        (\ c1 -> let { while = getY                `bindK` \ y ->
            	    	       if y > 0 then 
            	    	         (if y==10 then 
            	                    abortK (c1 False)     -- break
            	    	          else if y==3 then 
            	    	            setY (y-1) `bindK`  \ _ -> 
            	    	            abortK (while c1)      -- continue
            	    	          else unitK 1)   `bindK` \ _ ->
            	    	          getX       	  `bindK` \ x ->
            	    	          setX (x*y) 	  `bindK` \ _ ->
            	    	          setY (y-1) 	  `bindK` \ _ ->
            	    	          while
            	               else unitK True }
            	 in while c1)  `bindK` \ _ ->
        getX;

gotoTest :: K (ST (Integer, y, z) a) Integer;
gotoTest =  setX 1 `bindK` \ _ ->
            (\ c -> let { l1 _ =  (getX         `bindK` \ x ->
            	                   if x > 100 then
            	                     abortK (l2 ())
            	                   else
            	                     setX (x*2) `bindK` \ _ ->
            	                     abortK (l1 ())) l2
            	        ; l2 _ =   getX c }
            	    in l1 ()) 
         ;


bar :: Integer -> K r Integer;
bar x  =  callccK (\ k ->
            (if x==0 then unitK 1 else k x) `bindK` \ a ->
            unitK (100+a))
       ;

multlist :: [Integer] -> K (ST (Integer, y, String) a) (Integer, String) ;
multlist xs = setX 1         `bindK` \ _ ->
              setZ ""        `bindK` \ _ ->
              callccK (\ k ->
                let { aux []     = getX
                    ; aux (0:_)  = k 0
                    ; aux (y:ys) = getX       `bindK` \ x -> 
                                   getZ       `bindK` \ z -> 
                                   setX (x*y) `bindK` \ _ -> 
                                   setZ (z ++ " " ++ show y) 
                                              `bindK` \ _ ->
                                   aux ys } 
                in aux xs) `bindK` \ x ->
              getZ           `bindK` \ z ->
              unitK (x, z)
            ; 
}