module IOType where {

type MyState = ((Value, Value), String, String);

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;

type M a = ST 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 e = unitM (\ a -> mfixU e `bindM` \ v -> v a) `bindM` \ v ->
          e v;

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

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

getX :: M Value;  
getX   = \ ((x, y), i, o) -> (x, ((x, y), i, o)); 

getY :: M Value;  
getY   = \ ((x, y), i, o) -> (y, ((x, y), i, o)); 

readM :: M Value;
readM =  \ (s, c:cs, o) -> (Char c, (s, cs, o)); 

writeM :: Value -> M Value;
writeM v =  \ (s, i, o) -> (Unit, (s, i, o++showValue v)); 


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

-- IOのテスト
testloop :: ST Value;
testloop = getY                 `bindM` \ (Num n) ->
           if n>0 then
             getX               `bindM` \ (Num p) ->
             writeM (Str " n=") `bindM` \ _ ->
             writeM (Num n)     `bindM` \ _ ->
             writeM (Str " p=") `bindM` \ _ ->
             writeM (Num p)     `bindM` \ _ ->
             setX (Num (n*p))   `bindM` \ _ ->
             setY (Num (n-1))   `bindM` \ _ ->
             testloop
           else
             getX
          ;

test   :: Double -> ST ();
test n = setX (Num 1) 		    `bindM` \ _ -> 
         setY (Num n) 		    `bindM` \ _ ->
         testloop     		    `bindM` \ r -> 
         writeM (Str " result is ") `bindM` \ _ ->
         writeM r                   `bindM` \ _ ->
         unitM (); 

thd3 :: (a, b, c) -> c;
thd3 (a, b, c) = c;

testRun = thd3 (snd (test 10 ((Unit, Unit), "", ""))) ;  -- 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] 
          | Read | Write Expr -- for I/O
            deriving Show;

}