module STType where {

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

  unitM = unitST;
  bindM = bindST;

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

  setX :: x -> ST (x, y) Value;
  setX v = \ (x, y) -> (Unit, (v, y)); 

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

  getX :: ST (x, y) x;  
  getX   = \ (x, y) -> (x, (x, y));

  getY :: ST (x, y) y;
  getY   = \ (x, y) -> (y, (x, y));

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


  -- STのテスト
  factLoop :: ST (Integer, Integer) Integer;
  factLoop = getY         `bindM` \ n ->
             if n>0 then
               getX       `bindM` \ p ->
               setX (n*p) `bindM` \ _ ->
               setY (n-1) `bindM` \ _ ->
               factLoop
             else
               getX
             ;

  fact   :: Integer -> ST (Integer, Integer) Integer;
  fact n = setX 1    `bindM` \ _ -> 
           setY n    `bindM` \ _ ->
           factLoop;

  factRun = fst (fact 10 (0, 0));  -- 3628800.0

  -- 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
            | While Expr Expr | Begin [Expr] 
              deriving Show;
}