module ContType where 

type MyState = (Value, Value, 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 ST a = MyState -> (a, MyState)

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

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

setXST :: Value -> ST Value
setXST v = \ (x, y, z) -> (Unit, (v, y, z))

setYST :: Value -> ST Value
setYST v = \ (x, y, z) -> (Unit, (x, v, z))

setZST :: Value -> ST Value
setZST v = \ (x, y, z) -> (Unit, (x, y, v))

getXST :: ST Value
getXST   = \ (x, y, z) -> (x, (x, y, z))

getYST :: ST Value
getYST   = \ (x, y, z) -> (y, (x, y, z))

getZST :: ST Value
getZST   = \ (x, y, z) -> (z, (x, y, z))

type Result = ST ()
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 :: ST () -> 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 = \ c -> setXST v `bindST` c  

setY :: Value -> M Value
setY v = \ c -> setYST v `bindST` c  

setZ :: Value -> M Value
setZ v = \ c -> setZST v `bindST` c  


getX :: M Value  
getX = \ c -> getXST `bindST` c

getY :: M Value  
getY = \ c -> getYST `bindST` c 

getZ :: M Value  
getZ = \ c -> getZST `bindST` c